haskell/stackage
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage.git synced 2026-01-12 07:18:31 +01:00
Code Issues Actions 1 Packages Projects Releases Wiki Activity
6d192674a6
stackage/patching/patches/MFlow-0.4.5.4.patch
Michael Snoyman 69986d75a5 MFlow patch
2014-06-10 05:52:13 +03:00

13158 lines
473 KiB
Diff
Raw Blame History

diff -ru orig/MFlow.cabal new/MFlow.cabal
--- orig/MFlow.cabal 2014-06-10 05:51:27.009015855 +0300
+++ new/MFlow.cabal 2014-06-10 05:51:25.000000000 +0300
@@ -105,10 +105,10 @@
extensible-exceptions , base >4.0 && <5,
bytestring , containers , RefSerialize , TCache ,
stm >2, time, old-time , vector , directory ,
- utf8-string , wai , case-insensitive ,
+ utf8-string , wai , wai-extra, resourcet, case-insensitive ,
http-types , conduit ,conduit-extra, text , parsec , warp ,
warp-tls , random , blaze-html , blaze-markup ,
- monadloc, clientsession
+ monadloc, clientsession, pwstore-fast
exposed-modules: MFlow MFlow.Wai.Blaze.Html.All MFlow.Forms
MFlow.Forms.Admin MFlow.Cookies MFlow.Wai
MFlow.Forms.Blaze.Html MFlow.Forms.Test
@@ -128,7 +128,7 @@
-- hamlet , shakespeare, monadloc , aws , network , hscolour ,
-- persistent-template , persistent-sqlite , persistent ,
-- conduit , http-conduit , monad-logger , safecopy ,
--- time
+-- time, acid-state
-- main-is: demos-blaze.hs
-- buildable: True
-- hs-source-dirs: Demos
@@ -142,4 +142,4 @@
-- InitialConfig GenerateForm GenerateFormUndo GenerateFormUndoMsg WebService
-- LazyLoad
-- ghc-options: -iDemos -threaded -rtsopts
---
+
diff -ru orig/Setup.lhs new/Setup.lhs
--- orig/Setup.lhs 2014-06-10 05:51:26.953015857 +0300
+++ new/Setup.lhs 2014-06-10 05:51:25.000000000 +0300
@@ -1,5 +1,5 @@
-#! /usr/bin/runghc
-
-> import Distribution.Simple
->
-> main = defaultMain
+#! /usr/bin/runghc
+
+> import Distribution.Simple
+>
+> main = defaultMain
diff -ru orig/src/MFlow/Cookies.hs new/src/MFlow/Cookies.hs
--- orig/src/MFlow/Cookies.hs 2014-06-10 05:51:26.961015857 +0300
+++ new/src/MFlow/Cookies.hs 2014-06-10 05:51:25.000000000 +0300
@@ -1,188 +1,188 @@
-{-# OPTIONS -XScopedTypeVariables -XOverloadedStrings #-}
-
-module MFlow.Cookies (
- CookieT,
- Cookie(..),
- contentHtml,
- cookieuser,
- cookieHeaders,
- getCookies,
- paranoidEncryptCookie,
- paranoidDecryptCookie,
- encryptCookie,
- decryptCookie
- )
-where
-import Control.Monad(MonadPlus(..), guard, replicateM_, when)
-import Data.Char
-import Data.Maybe(fromMaybe, fromJust)
-import System.IO.Unsafe
-import Control.Exception(handle)
-import Data.Typeable
-import Unsafe.Coerce
-import Data.Monoid
-import Text.Parsec
-import Control.Monad.Identity
-import Data.ByteString.Char8 as B
-import Web.ClientSession
-import System.Environment
-
---import Debug.Trace
---(!>)= flip trace
-
-contentHtml :: (ByteString, ByteString)
-contentHtml= ("Content-Type", "text/html; charset=UTF-8")
-
-type CookieT = (B.ByteString,B.ByteString,B.ByteString,Maybe B.ByteString)
-
-data Cookie
- = UnEncryptedCookie CookieT
- | EncryptedCookie CookieT
- | ParanoidCookie CookieT
- deriving (Eq, Read, Show)
-
-cookieuser :: String
-cookieuser= "cookieuser"
-
-getCookies httpreq=
- case lookup "Cookie" $ httpreq of
- Just str -> splitCookies str :: [(B.ByteString, B.ByteString)]
- Nothing -> []
-
-cookieHeaders cs = Prelude.map (\c-> ( "Set-Cookie", showCookie c)) cs
-
-showCookie :: Cookie -> B.ByteString
-showCookie c@(EncryptedCookie _) = showCookie' $ decryptAndToTuple c
-showCookie c@(ParanoidCookie _) = showCookie' $ decryptAndToTuple c
-showCookie (UnEncryptedCookie c) = showCookie' c
-
-showCookie' (n,v,p,me) = n <> "=" <> v <>
- ";path=" <> p <>
- showMaxAge me
-
-showMaxAge Nothing = ""
-showMaxAge (Just e) = ";Max-age=" <> e
-
-splitCookies cookies = f cookies []
- where
- f s r | B.null s = r
- f xs0 r =
- let
- xs = B.dropWhile (==' ') xs0
- name = B.takeWhile (/='=') xs
- xs1 = B.dropWhile (/='=') xs
- xs2 = B.dropWhile (=='=') xs1
- val = B.takeWhile (/=';') xs2
- xs3 = B.dropWhile (/=';') xs2
- xs4 = B.dropWhile (==';') xs3
- xs5 = B.dropWhile (==' ') xs4
- in f xs5 ((name,val):r)
-
+{-# OPTIONS -XScopedTypeVariables -XOverloadedStrings #-}
+
+module MFlow.Cookies (
+ CookieT,
+ Cookie(..),
+ contentHtml,
+ cookieuser,
+ cookieHeaders,
+ getCookies,
+ paranoidEncryptCookie,
+ paranoidDecryptCookie,
+ encryptCookie,
+ decryptCookie
+ )
+where
+import Control.Monad(MonadPlus(..), guard, replicateM_, when)
+import Data.Char
+import Data.Maybe(fromMaybe, fromJust)
+import System.IO.Unsafe
+import Control.Exception(handle)
+import Data.Typeable
+import Unsafe.Coerce
+import Data.Monoid
+import Text.Parsec
+import Control.Monad.Identity
+import Data.ByteString.Char8 as B
+import Web.ClientSession
+import System.Environment
+
+--import Debug.Trace
+--(!>)= flip trace
+
+contentHtml :: (ByteString, ByteString)
+contentHtml= ("Content-Type", "text/html; charset=UTF-8")
+
+type CookieT = (B.ByteString,B.ByteString,B.ByteString,Maybe B.ByteString)
+
+data Cookie
+ = UnEncryptedCookie CookieT
+ | EncryptedCookie CookieT
+ | ParanoidCookie CookieT
+ deriving (Eq, Read, Show)
+
+cookieuser :: String
+cookieuser= "cookieuser"
+
+getCookies httpreq=
+ case lookup "Cookie" $ httpreq of
+ Just str -> splitCookies str :: [(B.ByteString, B.ByteString)]
+ Nothing -> []
+
+cookieHeaders cs = Prelude.map (\c-> ( "Set-Cookie", showCookie c)) cs
+
+showCookie :: Cookie -> B.ByteString
+showCookie c@(EncryptedCookie _) = showCookie' $ decryptAndToTuple c
+showCookie c@(ParanoidCookie _) = showCookie' $ decryptAndToTuple c
+showCookie (UnEncryptedCookie c) = showCookie' c
+
+showCookie' (n,v,p,me) = n <> "=" <> v <>
+ ";path=" <> p <>
+ showMaxAge me
+
+showMaxAge Nothing = ""
+showMaxAge (Just e) = ";Max-age=" <> e
+
+splitCookies cookies = f cookies []
+ where
+ f s r | B.null s = r
+ f xs0 r =
+ let
+ xs = B.dropWhile (==' ') xs0
+ name = B.takeWhile (/='=') xs
+ xs1 = B.dropWhile (/='=') xs
+ xs2 = B.dropWhile (=='=') xs1
+ val = B.takeWhile (/=';') xs2
+ xs3 = B.dropWhile (/=';') xs2
+ xs4 = B.dropWhile (==';') xs3
+ xs5 = B.dropWhile (==' ') xs4
+ in f xs5 ((name,val):r)
+
----------------------------
-
---readEnv :: Parser [(String,String)]
-readEnv = (do
- n <- urlEncoded
- string "="
- v <- urlEncoded
- return (n,v)) `sepBy` (string "&")
-
-urlEncoded :: Parsec String () String
-urlEncoded
- = many ( alphaNum `mplus` extra `mplus` safe
- `mplus` do{ char '+' ; return ' '}
- `mplus` do{ char '%' ; hexadecimal }
- )
-
-
---extra :: Parser Char
-extra = satisfy (`Prelude.elem` "!*'(),/\"")
---
---safe :: Parser Char
-safe = satisfy (`Prelude.elem` "$-_.")
-----
---hexadecimal :: Parser HexString
-hexadecimal = do d1 <- hexDigit
- d2 <- hexDigit
- return .chr $ toInt d1* 16 + toInt d2
- where toInt d | isDigit d = ord d - ord '0'
- toInt d | isHexDigit d = (ord d - ord 'A') + 10
- toInt d = error ("hex2int: illegal hex digit " ++ [d])
-
-
-
-decryptCookie :: Cookie -> IO Cookie
-decryptCookie c@(UnEncryptedCookie _) = return c
-decryptCookie (EncryptedCookie c) = decryptCookie' c
-decryptCookie (ParanoidCookie c) = paranoidDecryptCookie c
-
--- Uses 4 seperate keys, corresponding to the 4 seperate fields in the Cookie.
-paranoidEncryptCookie :: CookieT -> IO Cookie
-paranoidEncryptCookie (a,b,c,d) = do
- key1 <- getKey "CookieKey1.key"
- key2 <- getKey "CookieKey2.key"
- key3 <- getKey "CookieKey3.key"
- key4 <- getKey "CookieKey4.key"
- iv1 <- randomIV
- iv2 <- randomIV
- iv3 <- randomIV
- iv4 <- randomIV
- return $ ParanoidCookie
- ( encrypt key1 iv1 a,
- encrypt key2 iv2 b,
- encrypt key3 iv3 c,
- encryptMaybe key4 iv4 d)
-
-paranoidDecryptCookie :: CookieT -> IO Cookie
-paranoidDecryptCookie (a,b,c,d) = do
- key1 <- getKey "CookieKey1.key"
- key2 <- getKey "CookieKey2.key"
- key3 <- getKey "CookieKey3.key"
- key4 <- getKey "CookieKey4.key"
- return $ UnEncryptedCookie
- ( decryptFM key1 a,
- decryptFM key2 b,
- decryptFM key3 c,
- decryptMaybe key4 d)
-
--- Uses a single key to encrypt all 4 fields.
-encryptCookie :: CookieT -> IO Cookie
-encryptCookie (a,b,c,d) = do
- key <- getKey "CookieKey.key"
- iv1 <- randomIV
- iv2 <- randomIV
- iv3 <- randomIV
- iv4 <- randomIV
- return $ EncryptedCookie
- ( encrypt key iv1 a,
- encrypt key iv2 b,
- encrypt key iv3 c,
- encryptMaybe key iv4 d)
-
-decryptCookie' :: CookieT -> IO Cookie
-decryptCookie' (a,b,c,d) = do
- key <- getKey "CookieKey.key"
- return $ UnEncryptedCookie
- ( decryptFM key a,
- decryptFM key b,
- decryptFM key c,
- decryptMaybe key d)
-
-encryptMaybe :: Key -> IV -> Maybe ByteString -> Maybe ByteString
-encryptMaybe k i (Just s) = Just $ encrypt k i s
-encryptMaybe _ _ Nothing = Nothing
-
-decryptMaybe :: Key -> Maybe ByteString -> Maybe ByteString
-decryptMaybe k (Just s) = Just $ fromMaybe "" $ decrypt k s
-decryptMaybe _ Nothing = Nothing
-
-decryptFM :: Key -> ByteString -> ByteString
-decryptFM k b = fromMaybe "" $ decrypt k b
-
-cookieToTuple :: Cookie -> CookieT
-cookieToTuple (UnEncryptedCookie c) = c
-cookieToTuple (EncryptedCookie c) = c
-cookieToTuple (ParanoidCookie c) = c
-
-decryptAndToTuple :: Cookie -> CookieT
-decryptAndToTuple = cookieToTuple . unsafePerformIO . decryptCookie
+
+--readEnv :: Parser [(String,String)]
+readEnv = (do
+ n <- urlEncoded
+ string "="
+ v <- urlEncoded
+ return (n,v)) `sepBy` (string "&")
+
+urlEncoded :: Parsec String () String
+urlEncoded
+ = many ( alphaNum `mplus` extra `mplus` safe
+ `mplus` do{ char '+' ; return ' '}
+ `mplus` do{ char '%' ; hexadecimal }
+ )
+
+
+--extra :: Parser Char
+extra = satisfy (`Prelude.elem` "!*'(),/\"")
+--
+--safe :: Parser Char
+safe = satisfy (`Prelude.elem` "$-_.")
+----
+--hexadecimal :: Parser HexString
+hexadecimal = do d1 <- hexDigit
+ d2 <- hexDigit
+ return .chr $ toInt d1* 16 + toInt d2
+ where toInt d | isDigit d = ord d - ord '0'
+ toInt d | isHexDigit d = (ord d - ord 'A') + 10
+ toInt d = error ("hex2int: illegal hex digit " ++ [d])
+
+
+
+decryptCookie :: Cookie -> IO Cookie
+decryptCookie c@(UnEncryptedCookie _) = return c
+decryptCookie (EncryptedCookie c) = decryptCookie' c
+decryptCookie (ParanoidCookie c) = paranoidDecryptCookie c
+
+-- Uses 4 seperate keys, corresponding to the 4 seperate fields in the Cookie.
+paranoidEncryptCookie :: CookieT -> IO Cookie
+paranoidEncryptCookie (a,b,c,d) = do
+ key1 <- getKey "CookieKey1.key"
+ key2 <- getKey "CookieKey2.key"
+ key3 <- getKey "CookieKey3.key"
+ key4 <- getKey "CookieKey4.key"
+ iv1 <- randomIV
+ iv2 <- randomIV
+ iv3 <- randomIV
+ iv4 <- randomIV
+ return $ ParanoidCookie
+ ( encrypt key1 iv1 a,
+ encrypt key2 iv2 b,
+ encrypt key3 iv3 c,
+ encryptMaybe key4 iv4 d)
+
+paranoidDecryptCookie :: CookieT -> IO Cookie
+paranoidDecryptCookie (a,b,c,d) = do
+ key1 <- getKey "CookieKey1.key"
+ key2 <- getKey "CookieKey2.key"
+ key3 <- getKey "CookieKey3.key"
+ key4 <- getKey "CookieKey4.key"
+ return $ UnEncryptedCookie
+ ( decryptFM key1 a,
+ decryptFM key2 b,
+ decryptFM key3 c,
+ decryptMaybe key4 d)
+
+-- Uses a single key to encrypt all 4 fields.
+encryptCookie :: CookieT -> IO Cookie
+encryptCookie (a,b,c,d) = do
+ key <- getKey "CookieKey.key"
+ iv1 <- randomIV
+ iv2 <- randomIV
+ iv3 <- randomIV
+ iv4 <- randomIV
+ return $ EncryptedCookie
+ ( encrypt key iv1 a,
+ encrypt key iv2 b,
+ encrypt key iv3 c,
+ encryptMaybe key iv4 d)
+
+decryptCookie' :: CookieT -> IO Cookie
+decryptCookie' (a,b,c,d) = do
+ key <- getKey "CookieKey.key"
+ return $ UnEncryptedCookie
+ ( decryptFM key a,
+ decryptFM key b,
+ decryptFM key c,
+ decryptMaybe key d)
+
+encryptMaybe :: Key -> IV -> Maybe ByteString -> Maybe ByteString
+encryptMaybe k i (Just s) = Just $ encrypt k i s
+encryptMaybe _ _ Nothing = Nothing
+
+decryptMaybe :: Key -> Maybe ByteString -> Maybe ByteString
+decryptMaybe k (Just s) = Just $ fromMaybe "" $ decrypt k s
+decryptMaybe _ Nothing = Nothing
+
+decryptFM :: Key -> ByteString -> ByteString
+decryptFM k b = fromMaybe "" $ decrypt k b
+
+cookieToTuple :: Cookie -> CookieT
+cookieToTuple (UnEncryptedCookie c) = c
+cookieToTuple (EncryptedCookie c) = c
+cookieToTuple (ParanoidCookie c) = c
+
+decryptAndToTuple :: Cookie -> CookieT
+decryptAndToTuple = cookieToTuple . unsafePerformIO . decryptCookie
diff -ru orig/src/MFlow/Forms/Admin.hs new/src/MFlow/Forms/Admin.hs
--- orig/src/MFlow/Forms/Admin.hs 2014-06-10 05:51:26.985015856 +0300
+++ new/src/MFlow/Forms/Admin.hs 2014-06-10 05:51:25.000000000 +0300
@@ -1,175 +1,175 @@
-{-# OPTIONS
- -XScopedTypeVariables
-
- #-}
-module MFlow.Forms.Admin(adminLoop, wait, addAdminWF) where
+{-# OPTIONS
+ -XScopedTypeVariables
+
+ #-}
+module MFlow.Forms.Admin(adminLoop, wait, addAdminWF) where
import MFlow.Forms
import MFlow
-import MFlow.Forms.Blaze.Html
-import Text.Blaze.Html5 hiding (map)
-import Control.Applicative
-import Control.Workflow
-import Control.Monad.Trans
-import Data.TCache
-import Data.TCache.IndexQuery
-import System.Exit
-import System.IO
-import System.IO.Unsafe
-import Data.ByteString.Lazy.Char8 as B (unpack,tail,hGetNonBlocking,append, pack)
-import System.IO
-import Data.RefSerialize hiding ((<|>))
-import Data.Typeable
-import Data.Monoid
-import Data.Maybe
-import Data.Map as M (keys, toList)
-import System.Exit
-import Control.Exception as E
-import Control.Concurrent
-import Control.Concurrent.MVar
-import GHC.Conc
-
-
-ssyncCache= putStr "sync..." >> syncCache >> putStrLn "done"
-
--- | A small console interpreter with some commands:
---
--- [@sync@] Synchronize the cache with persistent storage (see `syncCache`)
---
--- [@flush@] Flush the cache
---
--- [@end@] Synchronize and exit
---
--- [@abort@] Exit. Do not synchronize
---
--- on exception, for example Control-c, it sync and exits.
--- It must be used as the last statement of the main procedure.
-adminLoop :: IO ()
-adminLoop= do
- msgs <- getMessageFlows
- putStrLn ""
- putStrLn $ "Served:"
- mapM putStrLn [ " http://server:port/"++ i | i <- M.keys msgs]
- putStrLn ""
- putStrLn "Commands: sync, flush, end, abort"
- adminLoop1
- `E.catch` (\(e:: E.SomeException) ->do
- ssyncCache
- error $ "\nException: "++ show e)
-
-adminLoop1= do
- putStr ">"; hFlush stdout
- op <- getLine
- case op of
- "sync" -> ssyncCache
- "flush" -> atomically flushAll >> putStrLn "flushed cache"
- "end" -> ssyncCache >> putStrLn "bye" >> exitWith ExitSuccess
- "abort" -> exitWith ExitSuccess
- _ -> return()
- adminLoop1
-
--- | execute the process and wait for its finalization.
--- then it synchronizes the cache
+import MFlow.Forms.Blaze.Html
+import Text.Blaze.Html5 hiding (map)
+import Control.Applicative
+import Control.Workflow
+import Control.Monad.Trans
+import Data.TCache
+import Data.TCache.IndexQuery
+import System.Exit
+import System.IO
+import System.IO.Unsafe
+import Data.ByteString.Lazy.Char8 as B (unpack,tail,hGetNonBlocking,append, pack)
+import System.IO
+import Data.RefSerialize hiding ((<|>))
+import Data.Typeable
+import Data.Monoid
+import Data.Maybe
+import Data.Map as M (keys, toList)
+import System.Exit
+import Control.Exception as E
+import Control.Concurrent
+import Control.Concurrent.MVar
+import GHC.Conc
+
+
+ssyncCache= putStr "sync..." >> syncCache >> putStrLn "done"
+
+-- | A small console interpreter with some commands:
+--
+-- [@sync@] Synchronize the cache with persistent storage (see `syncCache`)
+--
+-- [@flush@] Flush the cache
+--
+-- [@end@] Synchronize and exit
+--
+-- [@abort@] Exit. Do not synchronize
+--
+-- on exception, for example Control-c, it sync and exits.
+-- It must be used as the last statement of the main procedure.
+adminLoop :: IO ()
+adminLoop= do
+ msgs <- getMessageFlows
+ putStrLn ""
+ putStrLn $ "Served:"
+ mapM putStrLn [ " http://server:port/"++ i | i <- M.keys msgs]
+ putStrLn ""
+ putStrLn "Commands: sync, flush, end, abort"
+ adminLoop1
+ `E.catch` (\(e:: E.SomeException) ->do
+ ssyncCache
+ error $ "\nException: "++ show e)
+
+adminLoop1= do
+ putStr ">"; hFlush stdout
+ op <- getLine
+ case op of
+ "sync" -> ssyncCache
+ "flush" -> atomically flushAll >> putStrLn "flushed cache"
+ "end" -> ssyncCache >> putStrLn "bye" >> exitWith ExitSuccess
+ "abort" -> exitWith ExitSuccess
+ _ -> return()
+ adminLoop1
+
+-- | execute the process and wait for its finalization.
+-- then it synchronizes the cache
wait f= do
putChar '\n'
putStrLn "Using configuration: "
mapM_ putStrLn [k ++"= "++ show v | (k,v) <- M.toList config]
- putChar '\n'
- mv <- newEmptyMVar
- forkIO (f1 >> putMVar mv True)
- putStrLn "wait: ready"
+ putChar '\n'
+ mv <- newEmptyMVar
+ forkIO (f1 >> putMVar mv True)
+ putStrLn "wait: ready"
takeMVar mv
- return ()
- `E.catch` (\(e:: E.SomeException) ->do
- ssyncCache
- error $ "Signal: "++ show e)
-
- where
- f1= do
- mv <- newEmptyMVar
- n <- getNumProcessors
- putStr "Running in "
- putStr $ show n
- putStrLn " core(s)"
- hFlush stdout
- f
-
--- | Install the admin flow in the list of flows handled by `HackMessageFlow`
--- this gives access to an administrator page. It is necessary to
--- create an admin user with `setAdminUser`.
---
--- The administration page is reached with the path \"adminserv\"
-addAdminWF= addMessageFlows[("adminserv", runFlow $ transientNav adminMFlow)]
-
-
-adminMFlow :: FlowM Html IO ()
-adminMFlow= do
- let admin = getAdminName
- u <- getUser (Just admin) $ p << b << "Please login as Administrator" ++> userLogin
- op <- ask $ p <<< wlink "sync" (b << "sync")
- <|> p <<< wlink "flush" (b << "flush")
- <|> p <<< wlink "errors"(b << "errors")
- <|> p <<< wlink "users" (b << "users")
- <|> p <<< wlink "end" (b << "end")
- <|> wlink "abort" (b << "abort")
-
- case op of
- "users" -> users
- "sync" -> liftIO $ syncCache >> print "syncronized cache"
- "flush" -> liftIO $ atomically flushAll >> print "flushed cache"
-
- "errors" -> errors
- "end" -> liftIO $ syncCache >> print "bye" >> exitWith(ExitSuccess)
- "abort" -> liftIO $ exitWith(ExitSuccess)
- _ -> return()
- adminMFlow
-
-
-errors= do
- size <- liftIO $ hFileSize hlog
- if size == 0
- then ask $ wlink () (b << "no error log")
- else do
- liftIO $ hSeek hlog AbsoluteSeek 0
- log <- liftIO $ hGetNonBlocking hlog (fromIntegral size)
-
- let ls :: [[String ]]= runR readp $ pack "[" `append` (B.tail log) `append` pack "]"
- let rows= [wlink (Prelude.head e) (b << Prelude.head e) `waction` optionsUser : map (\x ->noWidget <++ fromStr x) (Prelude.tail e) | e <- ls]
- showFormList rows 0 10
- breturn()
-
-
-
-
-
-
-
-users= do
- users <- liftIO $ atomically $ return . map fst =<< indexOf userName
-
- showFormList [[wlink u (b << u) `waction` optionsUser ] | u<- users] 0 10
-
-showFormList
- :: [[View Html IO ()]]
- -> Int -> Int -> FlowM Html IO b
-showFormList ls n l= do
- nav <- ask $ updown n l <|> (list **> updown n l)
- showFormList ls nav l
-
- where
- list= table <<< firstOf (span1 n l [tr <<< cols e | e <- ls ])
-
- cols e= firstOf[td <<< c | c <- e]
- span1 n l = take l . drop n
- updown n l= wlink ( n +l) (b << "up ") <|> wlink ( n -l) (b << "down ") <++ br
-
-optionsUser us = do
- wfs <- liftIO $ return . M.keys =<< getMessageFlows
- stats <- let u= undefined
- in liftIO $ mapM (\wf -> getWFHistory wf (Token wf us u u u u u u)) wfs
- let wfss= filter (isJust . snd) $ zip wfs stats
- if null wfss
- then ask $ b << " not logs for this user" ++> wlink () (b << "Press here")
- else do
- wf <- ask $ firstOf [ wlink wf (p << wf) | (wf,_) <- wfss]
- ask $ p << unpack (showHistory . fromJust . fromJust $ lookup wf wfss) ++> wlink () (p << "press to menu")
-
+ return ()
+ `E.catch` (\(e:: E.SomeException) ->do
+ ssyncCache
+ error $ "Signal: "++ show e)
+
+ where
+ f1= do
+ mv <- newEmptyMVar
+ n <- getNumProcessors
+ putStr "Running in "
+ putStr $ show n
+ putStrLn " core(s)"
+ hFlush stdout
+ f
+
+-- | Install the admin flow in the list of flows handled by `HackMessageFlow`
+-- this gives access to an administrator page. It is necessary to
+-- create an admin user with `setAdminUser`.
+--
+-- The administration page is reached with the path \"adminserv\"
+addAdminWF= addMessageFlows[("adminserv", runFlow $ transientNav adminMFlow)]
+
+
+adminMFlow :: FlowM Html IO ()
+adminMFlow= do
+ let admin = getAdminName
+ u <- getUser (Just admin) $ p << b << "Please login as Administrator" ++> userLogin
+ op <- ask $ p <<< wlink "sync" (b << "sync")
+ <|> p <<< wlink "flush" (b << "flush")
+ <|> p <<< wlink "errors"(b << "errors")
+ <|> p <<< wlink "users" (b << "users")
+ <|> p <<< wlink "end" (b << "end")
+ <|> wlink "abort" (b << "abort")
+
+ case op of
+ "users" -> users
+ "sync" -> liftIO $ syncCache >> print "syncronized cache"
+ "flush" -> liftIO $ atomically flushAll >> print "flushed cache"
+
+ "errors" -> errors
+ "end" -> liftIO $ syncCache >> print "bye" >> exitWith(ExitSuccess)
+ "abort" -> liftIO $ exitWith(ExitSuccess)
+ _ -> return()
+ adminMFlow
+
+
+errors= do
+ size <- liftIO $ hFileSize hlog
+ if size == 0
+ then ask $ wlink () (b << "no error log")
+ else do
+ liftIO $ hSeek hlog AbsoluteSeek 0
+ log <- liftIO $ hGetNonBlocking hlog (fromIntegral size)
+
+ let ls :: [[String ]]= runR readp $ pack "[" `append` (B.tail log) `append` pack "]"
+ let rows= [wlink (Prelude.head e) (b << Prelude.head e) `waction` optionsUser : map (\x ->noWidget <++ fromStr x) (Prelude.tail e) | e <- ls]
+ showFormList rows 0 10
+ breturn()
+
+
+
+
+
+
+
+users= do
+ users <- liftIO $ atomically $ return . map fst =<< indexOf userName
+
+ showFormList [[wlink u (b << u) `waction` optionsUser ] | u<- users] 0 10
+
+showFormList
+ :: [[View Html IO ()]]
+ -> Int -> Int -> FlowM Html IO b
+showFormList ls n l= do
+ nav <- ask $ updown n l <|> (list **> updown n l)
+ showFormList ls nav l
+
+ where
+ list= table <<< firstOf (span1 n l [tr <<< cols e | e <- ls ])
+
+ cols e= firstOf[td <<< c | c <- e]
+ span1 n l = take l . drop n
+ updown n l= wlink ( n +l) (b << "up ") <|> wlink ( n -l) (b << "down ") <++ br
+
+optionsUser us = do
+ wfs <- liftIO $ return . M.keys =<< getMessageFlows
+ stats <- let u= undefined
+ in liftIO $ mapM (\wf -> getWFHistory wf (Token wf us u u u u u u)) wfs
+ let wfss= filter (isJust . snd) $ zip wfs stats
+ if null wfss
+ then ask $ b << " not logs for this user" ++> wlink () (b << "Press here")
+ else do
+ wf <- ask $ firstOf [ wlink wf (p << wf) | (wf,_) <- wfss]
+ ask $ p << unpack (showHistory . fromJust . fromJust $ lookup wf wfss) ++> wlink () (p << "press to menu")
+
diff -ru orig/src/MFlow/Forms/Blaze/Html.hs new/src/MFlow/Forms/Blaze/Html.hs
--- orig/src/MFlow/Forms/Blaze/Html.hs 2014-06-10 05:51:26.989015856 +0300
+++ new/src/MFlow/Forms/Blaze/Html.hs 2014-06-10 05:51:25.000000000 +0300
@@ -58,7 +58,7 @@
in if msel then tag ! selected (toValue ("" ::String)) else tag
- formAction action form = St.form ! acceptCharset "UTF-8" ! At.action (toValue action) ! method (toValue ("post" :: String)) $ form
+ formAction action method1 form = St.form ! acceptCharset "UTF-8" ! At.action (toValue action) ! method (toValue method1) $ form
fromStr= toMarkup
fromStrNoEncode = preEscapedToMarkup
diff -ru orig/src/MFlow/Forms/Internals.hs new/src/MFlow/Forms/Internals.hs
--- orig/src/MFlow/Forms/Internals.hs 2014-06-10 05:51:26.981015856 +0300
+++ new/src/MFlow/Forms/Internals.hs 2014-06-10 05:51:25.000000000 +0300
@@ -1,313 +1,345 @@
------------------------------------------------------------------------------
---
--- Module : MFlow.Forms.Internals
--- Copyright :
--- License : BSD3
---
--- Maintainer : agocorona@gmail.com
--- Stability : experimental
--- Portability :
---
--- |
---
------------------------------------------------------------------------------
-{-# OPTIONS -XDeriveDataTypeable
- -XExistentialQuantification
- -XScopedTypeVariables
- -XFlexibleInstances
- -XUndecidableInstances
- -XMultiParamTypeClasses
- -XGeneralizedNewtypeDeriving
- -XFlexibleContexts
- -XOverlappingInstances
- -XRecordWildCards
-#-}
-
-module MFlow.Forms.Internals where
-import MFlow
-import MFlow.Cookies
-import Control.Applicative
-import Data.Monoid
-import Control.Monad.Trans
-import Control.Monad.State
-import Data.ByteString.Lazy.UTF8 as B hiding (length, foldr, take)
-import qualified Data.ByteString.UTF8 as SB
-import Data.Typeable
-import Data.RefSerialize hiding((<|>))
-import Data.TCache
-import Data.TCache.Memoization
-import Data.TCache.DefaultPersistence
-import Data.TCache.Memoization
-import Data.Dynamic
-import qualified Data.Map as M
-import Unsafe.Coerce
-import Control.Workflow as WF
-import Control.Monad.Identity
-import Data.List
-import System.IO.Unsafe
-import Control.Concurrent.MVar
+-----------------------------------------------------------------------------
+--
+-- Module : MFlow.Forms.Internals
+-- Copyright :
+-- License : BSD3
+--
+-- Maintainer : agocorona@gmail.com
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+{-# OPTIONS -XDeriveDataTypeable
+ -XExistentialQuantification
+ -XScopedTypeVariables
+ -XFlexibleInstances
+ -XUndecidableInstances
+ -XMultiParamTypeClasses
+ -XGeneralizedNewtypeDeriving
+ -XFlexibleContexts
+ -XOverlappingInstances
+ -XRecordWildCards
+#-}
+
+module MFlow.Forms.Internals where
+import MFlow
+import MFlow.Cookies
+import Control.Applicative
+import Data.Monoid
+import Control.Monad.Trans
+import Control.Monad.State
+import Data.ByteString.Lazy.UTF8 as B hiding (length, foldr, take)
+import qualified Data.ByteString.UTF8 as SB
+import Data.Typeable
+import Data.RefSerialize hiding((<|>))
+import Data.TCache
+import Data.TCache.Memoization
+import Data.TCache.DefaultPersistence
+import Data.TCache.Memoization
+import Data.Dynamic
+import qualified Data.Map as M
+import Unsafe.Coerce
+import Control.Workflow as WF
+import Control.Monad.Identity
+import Data.List
+import System.IO.Unsafe
+import Control.Concurrent.MVar
import qualified Data.Text as T
import Data.Char
import Data.List(stripPrefix)
import Data.Maybe(isJust)
import Control.Concurrent.STM
import Data.TCache.Memoization
-
---
----- for traces
---
-
-import Control.Exception as CE
-import Control.Concurrent
-import Control.Monad.Loc
-
--- debug
---import Debug.Trace
---(!>) = flip trace
-
-
-data FailBack a = BackPoint a | NoBack a | GoBack deriving (Show,Typeable)
-
-
-instance (Serialize a) => Serialize (FailBack a ) where
- showp (BackPoint x)= insertString (fromString iCanFailBack) >> showp x
- showp (NoBack x) = insertString (fromString noFailBack) >> showp x
- showp GoBack = insertString (fromString repeatPlease)
-
- readp = choice [icanFailBackp,repeatPleasep,noFailBackp]
- where
- noFailBackp = symbol noFailBack >> readp >>= return . NoBack
- icanFailBackp = symbol iCanFailBack >> readp >>= return . BackPoint
- repeatPleasep = symbol repeatPlease >> return GoBack
-
-iCanFailBack= "B"
-repeatPlease= "G"
-noFailBack= "N"
-
-newtype Sup m a = Sup { runSup :: m (FailBack a ) }
-
-class MonadState s m => Supervise s m where
- supBack :: s -> m () -- called before backtracing. state passed is the previous
- supBack = const $ return () -- By default the state passed is the last one
-
- supervise :: m (FailBack a) -> m (FailBack a)
- supervise= id
-
-
-
-instance (Supervise s m)=> Monad (Sup m) where
- fail _ = Sup . return $ GoBack
- return x = Sup . return $ NoBack x
- x >>= f = Sup $ loop
- where
- loop = do
- s <- get
- v <- supervise $ runSup x -- !> "loop"
- case v of
- NoBack y -> supervise $ runSup (f y) -- !> "runback"
- BackPoint y -> do
- z <- supervise $ runSup (f y) -- !> "BACK"
- case z of
- GoBack -> supBack s >> loop -- !> "BACKTRACKING"
- other -> return other
- GoBack -> return $ GoBack
-
-
-fromFailBack (NoBack x) = x
-fromFailBack (BackPoint x)= x
-toFailBack x= NoBack x
-
-
--- | the FlowM monad executes the page navigation. It perform Backtracking when necessary to syncronize
--- when the user press the back button or when the user enter an arbitrary URL. The instruction pointer
--- is moved to the right position within the procedure to handle the request.
---
--- However this is transparent to the programmer, who codify in the style of a console application.
-newtype FlowM v m a= FlowM {runFlowM :: FlowMM v m a} deriving (Monad,MonadIO,Functor,MonadState(MFlowState v))
-flowM= FlowM
---runFlowM= runView
-
-{-# NOINLINE breturn #-}
-
--- | Use this instead of return to return from a computation with ask statements
---
--- This way when the user press the back button, the computation will execute back, to
--- the returned code, according with the user navigation.
-breturn :: (Monad m) => a -> FlowM v m a
-breturn = flowM . Sup . return . BackPoint -- !> "breturn"
-
-
-instance (Supervise s m,MonadIO m) => MonadIO (Sup m) where
- liftIO f= Sup $ liftIO f >>= \ x -> return $ NoBack x
-
-instance (Monad m,Functor m) => Functor (Sup m) where
- fmap f g= Sup $ do
- mr <- runSup g
- case mr of
- BackPoint x -> return . BackPoint $ f x
- NoBack x -> return . NoBack $ f x
- GoBack -> return $ GoBack
-
-
-liftSup f = Sup $ f >>= \x -> return $ NoBack x
-instance MonadTrans Sup where
- lift f = Sup $ f >>= \x -> return $ NoBack x
-
-
-instance (Supervise s m,MonadState s m) => MonadState s (Sup m) where
- get= lift get -- !> "get"
- put= lift . put
-
-type WState view m = StateT (MFlowState view) m
-type FlowMM view m= Sup (WState view m)
-
-data FormElm view a = FormElm view (Maybe a) deriving Typeable
-
-instance (Monoid view,Serialize a) => Serialize (FormElm view a) where
- showp (FormElm _ x)= showp x
- readp= readp >>= \x -> return $ FormElm mempty x
-
--- | @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`
---
--- It has 'Applicative', 'Alternative' and 'Monad' instances.
---
--- Things to know about these instances:
---
--- If the View expression does not validate, ask will present the page again.
---
--- /Alternative instance/: Both alternatives are executed. The rest is as usual
---
--- /Monad Instance/:
---
--- The rendering of each statement is added to the previous. If you want to avoid this, use 'wcallback'
---
--- The execution is stopped when the statement has a formlet-widget that does not validate and
--- return an invalid response (So it will present the page again if no other widget in the expression validates).
---
--- The monadic code is executed from the beginning each time the page is presented or refreshed
---
--- use 'pageFlow' if your page has more than one monadic computation with dynamic behaviour
---
--- use 'pageFlow' to identify each subflow branch of a conditional
---
--- For example:
---
--- > pageFlow "myid" $ do
--- > r <- formlet1
--- > liftIO $ ioaction1 r
--- > s <- formlet2
--- > liftIO $ ioaction2 s
--- > case s of
--- > True -> pageFlow "idtrue" $ do ....
--- > False -> paeFlow "idfalse" $ do ...
--- > ...
---
--- Here if @formlet2@ do not validate, @ioaction2@ is not executed. But if @formLet1@ validates and the
--- page is refreshed two times (because @formlet2@ has failed, see above),then @ioaction1@ is executed two times.
--- use 'cachedByKey' if you want to avoid repeated IO executions.
-newtype View v m a = View { runView :: WState v m (FormElm v a)}
-
-
-instance Monad m => Supervise (MFlowState v) (WState v m) where
- supBack st= do -- the previous state is recovered, with the exception of these fields:
- MFlowState{..} <- get
- put st{ mfEnv= mfEnv,mfToken=mfToken
- , mfPath=mfPath
- , mfData=mfData
- , mfTrace= mfTrace
+
+--
+---- for traces
+--
+
+import Control.Exception as CE
+import Control.Concurrent
+import Control.Monad.Loc
+
+-- debug
+import Debug.Trace
+(!>) = flip trace
+
+
+data FailBack a = BackPoint a | NoBack a | GoBack deriving (Show,Typeable)
+
+instance Functor FailBack where
+ fmap f GoBack= GoBack
+ fmap f (BackPoint x)= BackPoint $ f x
+ fmap f (NoBack x)= NoBack $ f x
+
+instance Applicative FailBack where
+ pure x = NoBack x
+ _ <*> GoBack = GoBack
+ GoBack <*> _ = GoBack
+ k <*> x = NoBack $ (fromFailBack k) (fromFailBack x)
+
+instance Alternative FailBack where
+ empty= GoBack
+ GoBack <|> f = f
+ f <|> _ = f
+
+instance (Serialize a) => Serialize (FailBack a ) where
+ showp (BackPoint x)= insertString (fromString iCanFailBack) >> showp x
+ showp (NoBack x) = insertString (fromString noFailBack) >> showp x
+ showp GoBack = insertString (fromString repeatPlease)
+
+ readp = choice [icanFailBackp,repeatPleasep,noFailBackp]
+ where
+ noFailBackp = symbol noFailBack >> readp >>= return . NoBack
+ icanFailBackp = symbol iCanFailBack >> readp >>= return . BackPoint
+ repeatPleasep = symbol repeatPlease >> return GoBack
+
+iCanFailBack= "B"
+repeatPlease= "G"
+noFailBack= "N"
+
+newtype Sup m a = Sup { runSup :: m (FailBack a ) }
+
+class MonadState s m => Supervise s m where
+ supBack :: s -> m () -- called before backtracing. state passed is the previous
+ supBack = const $ return () -- By default the state passed is the last one
+
+ supervise :: m (FailBack a) -> m (FailBack a)
+ supervise= id
+
+
+
+instance (Supervise s m)=> Monad (Sup m) where
+ fail _ = Sup . return $ GoBack
+ return x = Sup . return $ NoBack x
+ x >>= f = Sup $ loop
+ where
+ loop = do
+ s <- get
+ v <- supervise $ runSup x -- !> "loop"
+ case v of
+ NoBack y -> supervise $ runSup (f y) -- !> "runback"
+ BackPoint y -> do
+ z <- supervise $ runSup (f y) -- !> "BACK"
+ case z of
+ GoBack -> supBack s >> loop -- !> "BACKTRACKING"
+ other -> return other
+ GoBack -> return $ GoBack
+
+
+fromFailBack (NoBack x) = x
+fromFailBack (BackPoint x)= x
+toFailBack x= NoBack x
+
+instance (Monad m,Applicative m) => Applicative (Sup m) where
+ pure x = Sup . return $ NoBack x
+ f <*> g= Sup $ do
+ k <- runSup f
+ x <- runSup g
+ return $ k <*> x
+
+instance(Monad m, Applicative m) => Alternative (Sup m) where
+ empty = Sup . return $ GoBack
+ f <|> g= Sup $ do
+ x <- runSup f
+ case x of
+ GoBack -> runSup g !> "GOBACK"
+ _ -> return x
+
+-- | the FlowM monad executes the page navigation. It perform Backtracking when necessary to syncronize
+-- when the user press the back button or when the user enter an arbitrary URL. The instruction pointer
+-- is moved to the right position within the procedure to handle the request.
+--
+-- However this is transparent to the programmer, who codify in the style of a console application.
+newtype FlowM v m a= FlowM {runFlowM :: FlowMM v m a}
+ deriving (Applicative,Alternative,Monad,MonadIO,Functor
+ ,MonadState(MFlowState v))
+
+--runFlowM= runView
+
+{-# NOINLINE breturn #-}
+
+-- | Use this instead of return to return from a computation with ask statements
+--
+-- This way when the user press the back button, the computation will execute back, to
+-- the returned code, according with the user navigation.
+breturn :: (Monad m) => a -> FlowM v m a
+breturn = FlowM . Sup . return . BackPoint -- !> "breturn"
+
+
+instance (Supervise s m,MonadIO m) => MonadIO (Sup m) where
+ liftIO f= Sup $ liftIO f >>= \ x -> return $ NoBack x
+
+instance (Monad m,Functor m) => Functor (Sup m) where
+ fmap f g= Sup $ do
+ mr <- runSup g
+ case mr of
+ BackPoint x -> return . BackPoint $ f x
+ NoBack x -> return . NoBack $ f x
+ GoBack -> return $ GoBack
+
+
+liftSup f = Sup $ f >>= \x -> return $ NoBack x
+instance MonadTrans Sup where
+ lift f = Sup $ f >>= \x -> return $ NoBack x
+
+
+instance (Supervise s m,MonadState s m) => MonadState s (Sup m) where
+ get= lift get -- !> "get"
+ put= lift . put
+
+type WState view m = StateT (MFlowState view) m
+type FlowMM view m= Sup (WState view m)
+
+data FormElm view a = FormElm view (Maybe a) deriving Typeable
+
+instance (Monoid view,Serialize a) => Serialize (FormElm view a) where
+ showp (FormElm _ x)= showp x
+ readp= readp >>= \x -> return $ FormElm mempty x
+
+
+-- | @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`
+--
+-- It has 'Applicative', 'Alternative' and 'Monad' instances.
+--
+-- Things to know about these instances:
+--
+-- If the View expression does not validate, ask will present the page again.
+--
+-- /Alternative instance/: Both alternatives are executed. The rest is as usual
+--
+-- /Monad Instance/:
+--
+-- The rendering of each statement is added to the previous. If you want to avoid this, use 'wcallback'
+--
+-- The execution is stopped when the statement has a formlet-widget that does not validate and
+-- return an invalid response (So it will present the page again if no other widget in the expression validates).
+--
+-- The monadic code is executed from the beginning each time the page is presented or refreshed
+--
+-- use 'pageFlow' if your page has more than one monadic computation with dynamic behaviour
+--
+-- use 'pageFlow' to identify each subflow branch of a conditional
+--
+-- For example:
+--
+-- > pageFlow "myid" $ do
+-- > r <- formlet1
+-- > liftIO $ ioaction1 r
+-- > s <- formlet2
+-- > liftIO $ ioaction2 s
+-- > case s of
+-- > True -> pageFlow "idtrue" $ do ....
+-- > False -> paeFlow "idfalse" $ do ...
+-- > ...
+--
+-- Here if @formlet2@ do not validate, @ioaction2@ is not executed. But if @formLet1@ validates and the
+-- page is refreshed two times (because @formlet2@ has failed, see above),then @ioaction1@ is executed two times.
+-- use 'cachedByKey' if you want to avoid repeated IO executions.
+newtype View v m a = View { runView :: WState v m (FormElm v a)}
+
+
+instance Monad m => Supervise (MFlowState v) (WState v m) where
+ supBack st= do -- the previous state is recovered, with the exception of these fields:
+ MFlowState{..} <- get
+ put st{ mfEnv= mfEnv,mfToken=mfToken
+ , mfPath=mfPath
+ , mfData=mfData
+ , mfTrace= mfTrace
, inSync=False
- , newAsk=False}
-
-
-
-
-instance MonadLoc (FlowM v IO) where
- withLoc loc f = FlowM . Sup $ do
- withLoc loc $ do
- s <- get
- (r,s') <- lift $ do
- rs@(r,s') <- runStateT (runSup (runFlowM f) ) s
- `CE.catch` (handler1 loc s)
- case mfTrace s' of
- [] -> return rs
- trace -> return(r, s'{mfTrace= loc:trace})
- put s'
- return r
-
- where
- handler1 loc s (e :: SomeException)= do
- case CE.fromException e :: Maybe WFErrors of
- Just e -> CE.throw e -- !> ("TROWNF=" ++ show e)
- Nothing ->
- case CE.fromException e :: Maybe AsyncException of
- Just e -> CE.throw e -- !> ("TROWN ASYNCF=" ++ show e)
- Nothing ->
- return (GoBack, s{mfTrace= [show e]})
-
-
---instance (Serialize a,Typeable a, FormInput v) => MonadLoc (FlowM v (Workflow IO)) a where
--- withLoc loc f = FlowM . Sup $
--- withLoc loc $ do
--- s <- get
--- (r,s') <- lift . WF.step $ exec1d "jkkjk" ( runStateT (runSup $ runFlowM f) s) `CMT.catch` (handler1 loc s)
--- put s'
--- return r
---
--- where
--- handler1 loc s (e :: SomeException)=
--- return (GoBack, s{mfTrace= Just ["exception: " ++show e]})
-
-instance FormInput v => MonadLoc (View v IO) where
- withLoc loc f = View $ do
- withLoc loc $ do
- s <- get
- (r,s') <- lift $ do
- rs@(r,s') <- runStateT (runView f) s
- `CE.catch` (handler1 loc s)
- case mfTrace s' of
- [] -> return rs
- trace -> return(r, s'{mfTrace= loc:trace})
- put s'
- return r
-
- where
- handler1 loc s (e :: SomeException)= do
- case CE.fromException e :: Maybe WFErrors of
- Just e -> CE.throw e -- !> ("TROWN=" ++ show e)
- Nothing ->
- case CE.fromException e :: Maybe AsyncException of
- Just e -> CE.throw e -- !> ("TROWN ASYNC=" ++ show e)
- Nothing ->
- return (FormElm mempty Nothing, s{mfTrace= [show e]}) -- !> loc
-
-
-
-
-
-
-
-instance Functor (FormElm view ) where
- fmap f (FormElm form x)= FormElm form (fmap f x)
-
-instance (Monad m,Functor m) => Functor (View view m) where
- fmap f x= View $ fmap (fmap f) $ runView x
-
-
-instance (Monoid view,Functor m, Monad m) => Applicative (View view m) where
- pure a = View . return . FormElm mempty $ Just a
- View f <*> View g= View $
- f >>= \(FormElm form1 k) ->
- g >>= \(FormElm form2 x) ->
- return $ FormElm (form1 `mappend` form2) (k <*> x)
-
-instance (FormInput view,Functor m, Monad m) => Alternative (View view m) where
- empty= View $ return $ FormElm mempty Nothing
+ , newAsk=False}
+
+
+
+
+instance MonadLoc (FlowM v IO) where
+ withLoc loc f = FlowM . Sup $ do
+ withLoc loc $ do
+ s <- get
+ (r,s') <- lift $ do
+ rs@(r,s') <- runStateT (runSup (runFlowM f) ) s
+ `CE.catch` (handler1 loc s)
+ case mfTrace s' of
+ [] -> return rs
+ trace -> return(r, s'{mfTrace= loc:trace})
+ put s'
+ return r
+
+ where
+ handler1 loc s (e :: SomeException)= do
+ case CE.fromException e :: Maybe WFErrors of
+ Just e -> CE.throw e -- !> ("TROWNF=" ++ show e)
+ Nothing ->
+ case CE.fromException e :: Maybe AsyncException of
+ Just e -> CE.throw e -- !> ("TROWN ASYNCF=" ++ show e)
+ Nothing ->
+ return (GoBack, s{mfTrace= [show e]})
+
+
+--instance (Serialize a,Typeable a, FormInput v) => MonadLoc (FlowM v (Workflow IO)) a where
+-- withLoc loc f = FlowM . Sup $
+-- withLoc loc $ do
+-- s <- get
+-- (r,s') <- lift . WF.step $ exec1d "jkkjk" ( runStateT (runSup $ runFlowM f) s) `CMT.catch` (handler1 loc s)
+-- put s'
+-- return r
+--
+-- where
+-- handler1 loc s (e :: SomeException)=
+-- return (GoBack, s{mfTrace= Just ["exception: " ++show e]})
+
+instance FormInput v => MonadLoc (View v IO) where
+ withLoc loc f = View $ do
+ withLoc loc $ do
+ s <- get
+ (r,s') <- lift $ do
+ rs@(r,s') <- runStateT (runView f) s
+ `CE.catch` (handler1 loc s)
+ case mfTrace s' of
+ [] -> return rs
+ trace -> return(r, s'{mfTrace= loc:trace})
+ put s'
+ return r
+
+ where
+ handler1 loc s (e :: SomeException)= do
+ case CE.fromException e :: Maybe WFErrors of
+ Just e -> CE.throw e -- !> ("TROWN=" ++ show e)
+ Nothing ->
+ case CE.fromException e :: Maybe AsyncException of
+ Just e -> CE.throw e -- !> ("TROWN ASYNC=" ++ show e)
+ Nothing ->
+ return (FormElm mempty Nothing, s{mfTrace= [show e]}) -- !> loc
+
+
+
+
+
+
+
+instance Functor (FormElm view ) where
+ fmap f (FormElm form x)= FormElm form (fmap f x)
+
+instance (Monad m,Functor m) => Functor (View view m) where
+ fmap f x= View $ fmap (fmap f) $ runView x
+
+
+instance (Monoid view,Functor m, Monad m) => Applicative (View view m) where
+ pure a = View . return . FormElm mempty $ Just a
+ View f <*> View g= View $
+ f >>= \(FormElm form1 k) ->
+ g >>= \(FormElm form2 x) ->
+ return $ FormElm (form1 `mappend` form2) (k <*> x)
+
+instance (FormInput view,Functor m, Monad m) => Alternative (View view m) where
+ empty= View $ return $ FormElm mempty Nothing
View f <|> View g= View $ do
- path <- gets mfPagePath
+ path <- gets mfPagePath
FormElm form1 k <- f
s1 <- get
let path1 = mfPagePath s1
- put s1{mfPagePath=path}
+ put s1{mfPagePath=path}
FormElm form2 x <- g
s2 <- get
(mix,hasform) <- controlForms s1 s2 form1 form2
@@ -317,259 +349,259 @@
(_,Just _) -> path2
_ -> path
if hasform then put s2{needForm= HasForm,mfPagePath= path3}
- else put s2{mfPagePath=path3}
- return $ FormElm mix (k <|> x)
-
-
-instance (FormInput view, Monad m) => Monad (View view m) where
- View x >>= f = View $ do
- FormElm form1 mk <- x
- case mk of
- Just k -> do
+ else put s2{mfPagePath=path3}
+ return $ FormElm mix (k <|> x)
+
+
+instance (FormInput view, Monad m) => Monad (View view m) where
+ View x >>= f = View $ do
+ FormElm form1 mk <- x
+ case mk of
+ Just k -> do
st'' <- get
let st = st''{ linkMatched = False }
- put st
+ put st
FormElm form2 mk <- runView $ f k
st' <- get
(mix, hasform) <- controlForms st st' form1 form2
when hasform $ put st'{needForm= HasForm}
-
- return $ FormElm mix mk
- Nothing ->
- return $ FormElm form1 Nothing
-
-
-
- return = View . return . FormElm mempty . Just
--- fail msg= View . return $ FormElm [inRed msg] Nothing
-
-
-
-
-instance (FormInput v,Monad m, Functor m, Monoid a) => Monoid (View v m a) where
- mappend x y = mappend <$> x <*> y -- beware that both operands must validate to generate a sum
- mempty= return mempty
-
-
--- | It is a callback in the view monad. The callback rendering substitutes the widget rendering
--- when the latter is validated, without afecting the rendering of other widgets. This allow
--- the simultaneous execution of different behaviours in different widgets in the
--- same page. The inspiration is the callback primitive in the Seaside Web Framework
--- that allows similar functionality (See <http://www.seaside.st>)
---
--- This is the visible difference with 'waction' callbacks, which execute a
--- a flow in the FlowM monad that takes complete control of the navigation, while wactions are
--- executed whithin the same page.
-wcallback
- :: Monad m =>
- View view m a -> (a -> View view m b) -> View view m b
-wcallback (View x) f = View $ do
- FormElm form1 mk <- x
- case mk of
- Just k -> do
- modify $ \st -> st{linkMatched= False, needForm=NoElems}
+
+ return $ FormElm mix mk
+ Nothing ->
+ return $ FormElm form1 Nothing
+
+
+
+ return = View . return . FormElm mempty . Just
+-- fail msg= View . return $ FormElm [inRed msg] Nothing
+
+
+
+
+instance (FormInput v,Monad m, Functor m, Monoid a) => Monoid (View v m a) where
+ mappend x y = mappend <$> x <*> y -- beware that both operands must validate to generate a sum
+ mempty= return mempty
+
+
+-- | It is a callback in the view monad. The callback rendering substitutes the widget rendering
+-- when the latter is validated, without afecting the rendering of other widgets. This allow
+-- the simultaneous execution of different behaviours in different widgets in the
+-- same page. The inspiration is the callback primitive in the Seaside Web Framework
+-- that allows similar functionality (See <http://www.seaside.st>)
+--
+-- This is the visible difference with 'waction' callbacks, which execute a
+-- a flow in the FlowM monad that takes complete control of the navigation, while wactions are
+-- executed whithin the same page.
+wcallback
+ :: Monad m =>
+ View view m a -> (a -> View view m b) -> View view m b
+wcallback (View x) f = View $ do
+ FormElm form1 mk <- x
+ case mk of
+ Just k -> do
+ modify $ \st -> st{linkMatched= False, needForm=NoElems}
runView (f k)
-
- Nothing -> return $ FormElm form1 Nothing
-
-
-
-
-
-
-instance Monoid view => MonadTrans (View view) where
- lift f = View $ (lift f) >>= \x -> return $ FormElm mempty $ Just x
-
-instance MonadTrans (FlowM view) where
- lift f = FlowM $ lift (lift f) -- >>= \x -> return x
-
-instance (FormInput view, Monad m)=> MonadState (MFlowState view) (View view m) where
- get = View $ get >>= \x -> return $ FormElm mempty $ Just x
- put st = View $ put st >>= \x -> return $ FormElm mempty $ Just x
-
---instance (Monad m)=> MonadState (MFlowState view) (FlowM view m) where
--- get = FlowM $ get >>= \x -> return $ FormElm [] $ Just x
--- put st = FlowM $ put st >>= \x -> return $ FormElm [] $ Just x
-
-
-instance (FormInput view,MonadIO m) => MonadIO (View view m) where
- liftIO io= let x= liftIO io in x `seq` lift x -- to force liftIO==unsafePerformIO on the Identity monad
-
--- | Execute the widget in a monad and return the result in another.
-changeMonad :: (Monad m, Executable m1)
- => View v m1 a -> View v m a
-changeMonad w= View . StateT $ \s ->
- let (r,s')= execute $ runStateT ( runView w) s
- in mfSequence s' `seq` return (r,s')
+
+ Nothing -> return $ FormElm form1 Nothing
+
+
+
+
+
+
+instance Monoid view => MonadTrans (View view) where
+ lift f = View $ (lift f) >>= \x -> return $ FormElm mempty $ Just x
+
+instance MonadTrans (FlowM view) where
+ lift f = FlowM $ lift (lift f) -- >>= \x -> return x
+
+instance (FormInput view, Monad m)=> MonadState (MFlowState view) (View view m) where
+ get = View $ get >>= \x -> return $ FormElm mempty $ Just x
+ put st = View $ put st >>= \x -> return $ FormElm mempty $ Just x
+
+--instance (Monad m)=> MonadState (MFlowState view) (FlowM view m) where
+-- get = FlowM $ get >>= \x -> return $ FormElm [] $ Just x
+-- put st = FlowM $ put st >>= \x -> return $ FormElm [] $ Just x
+
+
+instance (FormInput view,MonadIO m) => MonadIO (View view m) where
+ liftIO io= let x= liftIO io in x `seq` lift x -- to force liftIO==unsafePerformIO on the Identity monad
+
+-- | Execute the widget in a monad and return the result in another.
+changeMonad :: (Monad m, Executable m1)
+ => View v m1 a -> View v m a
+changeMonad w= View . StateT $ \s ->
+ let (r,s')= execute $ runStateT ( runView w) s
+ in mfSequence s' `seq` return (r,s')
----- some combinators ----
-
--- | Join two widgets in the same page
--- the resulting widget, when `ask`ed with it, return a 2 tuple of their validation results
--- if both return Noting, the widget return @Nothing@ (invalid).
---
--- it has a low infix priority: @infixr 2@
---
--- > r <- ask widget1 <+> widget2
--- > case r of (Just x, Nothing) -> ..
-(<+>) , mix :: (Monad m, FormInput view)
- => View view m a
- -> View view m b
- -> View view m (Maybe a, Maybe b)
-mix digest1 digest2= View $ do
+
+-- | Join two widgets in the same page
+-- the resulting widget, when `ask`ed with it, return a 2 tuple of their validation results
+-- if both return Noting, the widget return @Nothing@ (invalid).
+--
+-- it has a low infix priority: @infixr 2@
+--
+-- > r <- ask widget1 <+> widget2
+-- > case r of (Just x, Nothing) -> ..
+(<+>) , mix :: (Monad m, FormInput view)
+ => View view m a
+ -> View view m b
+ -> View view m (Maybe a, Maybe b)
+mix digest1 digest2= View $ do
FormElm f1 mx' <- runView digest1
- s1 <- get
+ s1 <- get
FormElm f2 my' <- runView digest2
s2 <- get
(mix, hasform) <- controlForms s1 s2 f1 f2
- when hasform $ put s2{needForm= HasForm}
- return $ FormElm mix
- $ case (mx',my') of
- (Nothing, Nothing) -> Nothing
- other -> Just other
-
-infixr 2 <+>
-
-(<+>) = mix
-
-
-
--- | The first elem result (even if it is not validated) is discarded, and the secod is returned
--- . This contrast with the applicative operator '*>' which fails the whole validation if
--- the validation of the first elem fails.
---
--- The first element is displayed however, as happens in the case of '*>' .
---
--- Here @w\'s@ are widgets and @r\'s@ are returned values
---
--- @(w1 <* w2)@ will return @Just r1@ only if w1 and w2 are validated
---
--- @(w1 <** w2)@ will return @Just r1@ even if w2 is not validated
---
--- it has a low infix priority: @infixr 1@
-
-(**>) :: (Functor m, Monad m, FormInput view)
- => View view m a -> View view m b -> View view m b
+ when hasform $ put s2{needForm= HasForm}
+ return $ FormElm mix
+ $ case (mx',my') of
+ (Nothing, Nothing) -> Nothing
+ other -> Just other
+
+infixr 2 <+>
+
+(<+>) = mix
+
+
+
+-- | The first elem result (even if it is not validated) is discarded, and the secod is returned
+-- . This contrast with the applicative operator '*>' which fails the whole validation if
+-- the validation of the first elem fails.
+--
+-- The first element is displayed however, as happens in the case of '*>' .
+--
+-- Here @w\'s@ are widgets and @r\'s@ are returned values
+--
+-- @(w1 <* w2)@ will return @Just r1@ only if w1 and w2 are validated
+--
+-- @(w1 <** w2)@ will return @Just r1@ even if w2 is not validated
+--
+-- it has a low infix priority: @infixr 1@
+
+(**>) :: (Functor m, Monad m, FormInput view)
+ => View view m a -> View view m b -> View view m b
--(**>) form1 form2 = valid form1 *> form2
(**>) f g = View $ do
FormElm form1 k <- runView $ valid f
- s1 <- get
+ s1 <- get
FormElm form2 x <- runView g
s2 <- get
(mix,hasform) <- controlForms s1 s2 form1 form2
- when hasform $ put s2{needForm= HasForm}
- return $ FormElm mix (k *> x)
-
-
-
-valid form= View $ do
- FormElm form mx <- runView form
- return $ FormElm form $ Just undefined
-
-infixr 1 **> , <**
-
--- | The second elem result (even if it is not validated) is discarded, and the first is returned
--- . This contrast with the applicative operator '*>' which fails the whole validation if
--- the validation of the second elem fails.
--- The second element is displayed however, as in the case of '<*'.
--- see the `<**` examples
---
--- it has a low infix priority: @infixr 1@
-(<**) :: (Functor m, Monad m, FormInput view) =>
- View view m a -> View view m b -> View view m a
--- (<**) form1 form2 = form1 <* valid form2
+ when hasform $ put s2{needForm= HasForm}
+ return $ FormElm mix (k *> x)
+
+
+
+valid form= View $ do
+ FormElm form mx <- runView form
+ return $ FormElm form $ Just undefined
+
+infixr 1 **> , <**
+
+-- | The second elem result (even if it is not validated) is discarded, and the first is returned
+-- . This contrast with the applicative operator '*>' which fails the whole validation if
+-- the validation of the second elem fails.
+-- The second element is displayed however, as in the case of '<*'.
+-- see the `<**` examples
+--
+-- it has a low infix priority: @infixr 1@
+(<**) :: (Functor m, Monad m, FormInput view) =>
+ View view m a -> View view m b -> View view m a
+-- (<**) form1 form2 = form1 <* valid form2
(<**) f g = View $ do
FormElm form1 k <- runView f
- s1 <- get
+ s1 <- get
FormElm form2 x <- runView $ valid g
s2 <- get
(mix,hasform) <- controlForms s1 s2 form1 form2
- when hasform $ put s2{needForm= HasForm}
- return $ FormElm mix (k <* x)
-
+ when hasform $ put s2{needForm= HasForm}
+ return $ FormElm mix (k <* x)
+
-------- Flow control
-
--- | True if the flow is going back (as a result of the back button pressed in the web browser).
--- Usually this check is nos necessary unless conditional code make it necessary
---
--- @menu= do
--- mop <- getGoStraighTo
--- case mop of
--- Just goop -> goop
--- Nothing -> do
--- r \<- `ask` option1 \<|> option2
--- case r of
--- op1 -> setGoStraighTo (Just goop1) >> goop1
--- op2 -> setGoStraighTo (Just goop2) >> goop2@
---
--- This pseudocode below would execute the ask of the menu once. But the user will never have
--- the possibility to see the menu again. To let him choose other option, the code
--- has to be change to
---
--- @menu= do
--- mop <- getGoStraighTo
--- back <- `goingBack`
--- case (mop,back) of
--- (Just goop,False) -> goop
--- _ -> do
--- r \<- `ask` option1 \<|> option2
--- case r of
--- op1 -> setGoStraighTo (Just goop1) >> goop1
--- op2 -> setGoStraighTo (Just goop2) >> goop2@
---
--- However this is very specialized. Normally the back button detection is not necessary.
--- In a persistent flow (with step) even this default entry option would be completely automatic,
--- since the process would restart at the last page visited.
-goingBack :: MonadState (MFlowState view) m => m Bool
-goingBack = do
- st <- get
- return $ not (inSync st) && not (newAsk st)
-
--- | Will prevent the Suprack beyond the point where 'preventGoingBack' is located.
--- If the user press the back button beyond that point, the flow parameter is executed, usually
--- it is an ask statement with a message. If the flow is not going back, it does nothing. It is a cut in Supracking
---
--- It is useful when an undoable transaction has been commited. For example, after a payment.
---
--- This example show a message when the user go back and press again to pay
---
--- > ask $ wlink () << b << "press here to pay 100000 $ "
--- > payIt
--- > preventGoingBack . ask $ b << "You paid 10000 $ one time"
--- > ++> wlink () << b << " Please press here to complete the proccess"
--- > ask $ wlink () << b << "OK, press here to go to the menu or press the back button to verify that you can not pay again"
--- > where
--- > payIt= liftIO $ print "paying"
-
-preventGoingBack
- :: ( Functor m, MonadIO m, FormInput v) => FlowM v m () -> FlowM v m ()
-preventGoingBack msg= do
- back <- goingBack
- if not back then breturn() else do
- breturn() -- will not go back beyond this
- clearEnv
- modify $ \s -> s{newAsk= True}
- msg
-
-
--- | executes the first computation when going forward and the second computation when backtracking.
--- Depending on how the second computation finishes, the flow will resume forward or backward.
-onBacktrack :: Monad m => m a -> FlowM v m a -> FlowM v m a
-onBacktrack doit onback= do
- back <- goingBack
- case back of
- False -> (lift doit) >>= breturn
- True -> onback
-
--- | less powerflul version of `onBacktrack`: The second computation simply undo the effect of
--- the first one, and the flow continues backward ever. It can be used as a rollback mechanism in
--- the context of long running transactions.
-compensate :: Monad m => m a -> m a -> FlowM v m a
-compensate doit undoit= doit `onBacktrack` ( (lift undoit) >> fail "")
+
+-- | True if the flow is going back (as a result of the back button pressed in the web browser).
+-- Usually this check is nos necessary unless conditional code make it necessary
+--
+-- @menu= do
+-- mop <- getGoStraighTo
+-- case mop of
+-- Just goop -> goop
+-- Nothing -> do
+-- r \<- `ask` option1 \<|> option2
+-- case r of
+-- op1 -> setGoStraighTo (Just goop1) >> goop1
+-- op2 -> setGoStraighTo (Just goop2) >> goop2@
+--
+-- This pseudocode below would execute the ask of the menu once. But the user will never have
+-- the possibility to see the menu again. To let him choose other option, the code
+-- has to be change to
+--
+-- @menu= do
+-- mop <- getGoStraighTo
+-- back <- `goingBack`
+-- case (mop,back) of
+-- (Just goop,False) -> goop
+-- _ -> do
+-- r \<- `ask` option1 \<|> option2
+-- case r of
+-- op1 -> setGoStraighTo (Just goop1) >> goop1
+-- op2 -> setGoStraighTo (Just goop2) >> goop2@
+--
+-- However this is very specialized. Normally the back button detection is not necessary.
+-- In a persistent flow (with step) even this default entry option would be completely automatic,
+-- since the process would restart at the last page visited.
+goingBack :: MonadState (MFlowState view) m => m Bool
+goingBack = do
+ st <- get
+ return $ not (inSync st) && not (newAsk st)
+
+-- | Will prevent the Suprack beyond the point where 'preventGoingBack' is located.
+-- If the user press the back button beyond that point, the flow parameter is executed, usually
+-- it is an ask statement with a message. If the flow is not going back, it does nothing. It is a cut in Supracking
+--
+-- It is useful when an undoable transaction has been commited. For example, after a payment.
+--
+-- This example show a message when the user go back and press again to pay
+--
+-- > ask $ wlink () << b << "press here to pay 100000 $ "
+-- > payIt
+-- > preventGoingBack . ask $ b << "You paid 10000 $ one time"
+-- > ++> wlink () << b << " Please press here to complete the proccess"
+-- > ask $ wlink () << b << "OK, press here to go to the menu or press the back button to verify that you can not pay again"
+-- > where
+-- > payIt= liftIO $ print "paying"
+
+preventGoingBack
+ :: ( Functor m, MonadIO m, FormInput v) => FlowM v m () -> FlowM v m ()
+preventGoingBack msg= do
+ back <- goingBack
+ if not back then breturn() else do
+ breturn() -- will not go back beyond this
+ clearEnv
+ modify $ \s -> s{newAsk= True}
+ msg
+
+
+-- | executes the first computation when going forward and the second computation when backtracking.
+-- Depending on how the second computation finishes, the flow will resume forward or backward.
+onBacktrack :: Monad m => m a -> FlowM v m a -> FlowM v m a
+onBacktrack doit onback= do
+ back <- goingBack
+ case back of
+ False -> (lift doit) >>= breturn
+ True -> onback
+
+-- | less powerflul version of `onBacktrack`: The second computation simply undo the effect of
+-- the first one, and the flow continues backward ever. It can be used as a rollback mechanism in
+-- the context of long running transactions.
+compensate :: Monad m => m a -> m a -> FlowM v m a
+compensate doit undoit= doit `onBacktrack` ( (lift undoit) >> fail "")
--orElse :: FormInput v => FlowM v IO a -> FlowM v IO a -> FlowM v IO a
@@ -595,91 +627,96 @@
-- case mr of
-- Nothing -> retry
-- Just v -> return v
-
+
type Lang= String
-needForm1 st= case needForm st of
- HasForm -> False
- HasElems -> True
- NoElems -> False
-
-data NeedForm= HasForm | HasElems | NoElems deriving Show
-
-data MFlowState view= MFlowState{
- mfSequence :: Int,
- mfCached :: Bool,
- newAsk :: Bool,
- inSync :: Bool,
- mfLang :: Lang,
- mfEnv :: Params,
- needForm :: NeedForm,
- mfToken :: Token,
- mfkillTime :: Int,
- mfSessionTime :: Integer,
- mfCookies :: [Cookie],
- mfHttpHeaders :: [(SB.ByteString,SB.ByteString)],
- mfHeader :: view -> view,
- mfDebug :: Bool,
- mfRequirements :: [Requirement],
- mfData :: M.Map TypeRep Void,
- mfAjax :: Maybe (M.Map String Void),
- mfSeqCache :: Int,
- notSyncInAction :: Bool,
-
- -- Link management
+--needForm1 st= case needForm st of
+-- HasForm -> False
+-- HasElems _ -> True
+-- NoElems -> False
+
+
+
+data NeedForm= HasForm | HasElems | NoElems deriving Show
+
+data MFlowState view= MFlowState{
+ mfSequence :: Int,
+ mfCached :: Bool,
+ newAsk :: Bool,
+ inSync :: Bool,
+ mfLang :: Lang,
+ mfEnv :: Params,
+ needForm :: NeedForm,
+ mfFileUpload :: Bool,
+ mfToken :: Token,
+ mfkillTime :: Int,
+ mfSessionTime :: Integer,
+ mfCookies :: [Cookie],
+ mfHttpHeaders :: [(SB.ByteString,SB.ByteString)],
+ mfHeader :: view -> view,
+ mfDebug :: Bool,
+ mfRequirements :: [Requirement],
+ mfInstalledScripts :: [WebRequirement],
+ mfData :: M.Map TypeRep Void,
+ mfAjax :: Maybe (M.Map String Void),
+ mfSeqCache :: Int,
+ notSyncInAction :: Bool,
+
+ -- Link management
mfPath :: [String],
- mfPagePath :: [String],
- mfPrefix :: String,
--- mfPIndex :: Int,
- mfPageFlow :: Bool,
+ mfPagePath :: [String],
+ mfPrefix :: String,
+-- mfPIndex :: Int,
+ mfPageFlow :: Bool,
linkMatched :: Bool,
--- mfPendingPath :: [String],
-
-
- mfAutorefresh :: Bool,
- mfTrace :: [String],
- mfClear :: Bool
- }
- deriving Typeable
-
-type Void = Char
-
-mFlowState0 :: (FormInput view) => MFlowState view
-mFlowState0 = MFlowState 0 False True True "en"
- [] NoElems (error "token of mFlowState0 used")
- 0 0 [] [] stdHeader False [] M.empty Nothing 0 False [] [] "" False False False [] False
-
-
--- | Set user-defined data in the context of the session.
---
--- The data is indexed by type in a map. So the user can insert-retrieve different kinds of data
--- in the session context.
---
--- This example define @addHistory@ and @getHistory@ to maintain a Html log in the session of a Flow:
---
--- > newtype History = History ( Html) deriving Typeable
--- > setHistory html= setSessionData $ History html
--- > getHistory= getSessionData `onNothing` return (History mempty) >>= \(History h) -> return h
--- > addHistory html= do
--- > html' <- getHistory
--- > setHistory $ html' `mappend` html
-
-setSessionData :: (Typeable a,MonadState (MFlowState view) m) => a -> m ()
-setSessionData x=
- modify $ \st -> st{mfData= M.insert (typeOf x ) (unsafeCoerce x) (mfData st)}
-
-delSessionData x=
- modify $ \st -> st{mfData= M.delete (typeOf x ) (mfData st)}
-
--- | Get the session data of the desired type if there is any.
-getSessionData :: (Typeable a, MonadState (MFlowState view) m) => m (Maybe a)
-getSessionData = resp where
- resp= gets mfData >>= \list ->
- case M.lookup ( typeOf $ typeResp resp ) list of
- Just x -> return . Just $ unsafeCoerce x
- Nothing -> return $ Nothing
- typeResp :: m (Maybe x) -> x
- typeResp= undefined
+-- mfPendingPath :: [String],
+
+
+ mfAutorefresh :: Bool,
+ mfTrace :: [String],
+ mfClear :: Bool
+ }
+ deriving Typeable
+
+type Void = Char
+
+mFlowState0 :: (FormInput view) => MFlowState view
+mFlowState0 = MFlowState 0 False True True "en"
+ [] NoElems False (error "token of mFlowState0 used")
+ 0 0 [] [] stdHeader False [] [] M.empty Nothing 0 False
+ [] [] "" False False False [] False
+
+
+-- | Set user-defined data in the context of the session.
+--
+-- The data is indexed by type in a map. So the user can insert-retrieve different kinds of data
+-- in the session context.
+--
+-- This example define @addHistory@ and @getHistory@ to maintain a Html log in the session of a Flow:
+--
+-- > newtype History = History ( Html) deriving Typeable
+-- > setHistory html= setSessionData $ History html
+-- > getHistory= getSessionData `onNothing` return (History mempty) >>= \(History h) -> return h
+-- > addHistory html= do
+-- > html' <- getHistory
+-- > setHistory $ html' `mappend` html
+
+setSessionData :: (Typeable a,MonadState (MFlowState view) m) => a -> m ()
+setSessionData x=
+ modify $ \st -> st{mfData= M.insert (typeOf x ) (unsafeCoerce x) (mfData st)}
+
+delSessionData x=
+ modify $ \st -> st{mfData= M.delete (typeOf x ) (mfData st)}
+
+-- | Get the session data of the desired type if there is any.
+getSessionData :: (Typeable a, MonadState (MFlowState view) m) => m (Maybe a)
+getSessionData = resp where
+ resp= gets mfData >>= \list ->
+ case M.lookup ( typeOf $ typeResp resp ) list of
+ Just x -> return . Just $ unsafeCoerce x
+ Nothing -> return $ Nothing
+ typeResp :: m (Maybe x) -> x
+ typeResp= undefined
-- | getSessionData specialized for the View monad. if Nothing, the monadic computation
-- does not continue.
@@ -691,554 +728,555 @@
-- | Return the session identifier
getSessionId :: MonadState (MFlowState v) m => m String
getSessionId= gets mfToken >>= return . key
-
--- | Return the user language. Now it is fixed to "en"
-getLang :: MonadState (MFlowState view) m => m String
-getLang= gets mfLang
-
-getToken :: MonadState (MFlowState view) m => m Token
-getToken= gets mfToken
-
-
--- get a parameter form the las received response
-getEnv :: MonadState (MFlowState view) m => m Params
-getEnv = gets mfEnv
-
-stdHeader v = v
-
-
--- | Set the header-footer that will enclose the widgets. It must be provided in the
--- same formatting than them, altrough with normalization to byteStrings any formatting can be used
---
--- This header uses XML trough Haskell Server Pages (<http://hackage.haskell.org/package/hsp>)
---
--- @
--- setHeader $ \c ->
--- \<html\>
--- \<head\>
--- \<title\> my title \</title\>
--- \<meta name= \"Keywords\" content= \"sci-fi\" /\>)
--- \</head\>
--- \<body style= \"margin-left:5%;margin-right:5%\"\>
--- \<% c %\>
--- \</body\>
--- \</html\>
--- @
---
--- This header uses "Text.XHtml"
---
--- @
--- setHeader $ \c ->
--- `thehtml`
--- << (`header`
--- << (`thetitle` << title +++
--- `meta` ! [`name` \"Keywords\",content \"sci-fi\"])) +++
--- `body` ! [`style` \"margin-left:5%;margin-right:5%\"] c
--- @
---
--- This header uses both. It uses byteString tags
---
--- @
--- setHeader $ \c ->
--- `bhtml` [] $
--- `btag` "head" [] $
--- (`toByteString` (thetitle << title) `append`
--- `toByteString` <meta name= \"Keywords\" content= \"sci-fi\" />) `append`
--- `bbody` [(\"style\", \"margin-left:5%;margin-right:5%\")] c
--- @
---
-setHeader :: MonadState (MFlowState view) m => (view -> view) -> m ()
-setHeader header= do
- fs <- get
- put fs{mfHeader= header}
-
-
-
--- | Return the current header
-getHeader :: ( Monad m) => FlowM view m (view -> view)
-getHeader= gets mfHeader
-
--- | Add another header embedded in the previous one
-addHeader new= do
- fhtml <- getHeader
- setHeader $ fhtml . new
-
--- | Set an HTTP cookie
-setCookie :: MonadState (MFlowState view) m
- => String -- ^ name
- -> String -- ^ value
- -> String -- ^ path
- -> Maybe Integer -- ^ Max-Age in seconds. Nothing for a session cookie
- -> m ()
-setCookie n v p me=
- modify $ \st -> st{mfCookies= (UnEncryptedCookie
- ( SB.fromString n,
- SB.fromString v,
- SB.fromString p,
- fmap (SB.fromString . show) me)):mfCookies st }
-
-setParanoidCookie :: MonadState (MFlowState view) m
- => String -- ^ name
- -> String -- ^ value
- -> String -- ^ path
+
+-- | Return the user language. Now it is fixed to "en"
+getLang :: MonadState (MFlowState view) m => m String
+getLang= gets mfLang
+
+getToken :: MonadState (MFlowState view) m => m Token
+getToken= gets mfToken
+
+
+-- get a parameter form the las received response
+getEnv :: MonadState (MFlowState view) m => m Params
+getEnv = gets mfEnv
+
+stdHeader v = v
+
+
+-- | Set the header-footer that will enclose the widgets. It must be provided in the
+-- same formatting than them, altrough with normalization to byteStrings any formatting can be used
+--
+-- This header uses XML trough Haskell Server Pages (<http://hackage.haskell.org/package/hsp>)
+--
+-- @
+-- setHeader $ \c ->
+-- \<html\>
+-- \<head\>
+-- \<title\> my title \</title\>
+-- \<meta name= \"Keywords\" content= \"sci-fi\" /\>)
+-- \</head\>
+-- \<body style= \"margin-left:5%;margin-right:5%\"\>
+-- \<% c %\>
+-- \</body\>
+-- \</html\>
+-- @
+--
+-- This header uses "Text.XHtml"
+--
+-- @
+-- setHeader $ \c ->
+-- `thehtml`
+-- << (`header`
+-- << (`thetitle` << title +++
+-- `meta` ! [`name` \"Keywords\",content \"sci-fi\"])) +++
+-- `body` ! [`style` \"margin-left:5%;margin-right:5%\"] c
+-- @
+--
+-- This header uses both. It uses byteString tags
+--
+-- @
+-- setHeader $ \c ->
+-- `bhtml` [] $
+-- `btag` "head" [] $
+-- (`toByteString` (thetitle << title) `append`
+-- `toByteString` <meta name= \"Keywords\" content= \"sci-fi\" />) `append`
+-- `bbody` [(\"style\", \"margin-left:5%;margin-right:5%\")] c
+-- @
+--
+setHeader :: MonadState (MFlowState view) m => (view -> view) -> m ()
+setHeader header= do
+ fs <- get
+ put fs{mfHeader= header}
+
+
+
+-- | Return the current header
+getHeader :: ( Monad m) => FlowM view m (view -> view)
+getHeader= gets mfHeader
+
+-- | Add another header embedded in the previous one
+addHeader new= do
+ fhtml <- getHeader
+ setHeader $ fhtml . new
+
+-- | Set an HTTP cookie
+setCookie :: MonadState (MFlowState view) m
+ => String -- ^ name
+ -> String -- ^ value
+ -> String -- ^ path
+ -> Maybe Integer -- ^ Max-Age in seconds. Nothing for a session cookie
+ -> m ()
+setCookie n v p me=
+ modify $ \st -> st{mfCookies= (UnEncryptedCookie
+ ( SB.fromString n,
+ SB.fromString v,
+ SB.fromString p,
+ fmap (SB.fromString . show) me)):mfCookies st }
+
+setParanoidCookie :: MonadState (MFlowState view) m
+ => String -- ^ name
+ -> String -- ^ value
+ -> String -- ^ path
-> Maybe Integer -- ^ Max-Age in seconds. Nothing for a session cookie
- -> m ()
-setParanoidCookie n v p me = setEncryptedCookie' n v p me paranoidEncryptCookie
+ -> m ()
+setParanoidCookie n v p me = setEncryptedCookie' n v p me paranoidEncryptCookie
-setEncryptedCookie :: MonadState (MFlowState view) m
- => String -- ^ name
- -> String -- ^ value
- -> String -- ^ path
+setEncryptedCookie :: MonadState (MFlowState view) m
+ => String -- ^ name
+ -> String -- ^ value
+ -> String -- ^ path
-> Maybe Integer -- ^ Max-Age in seconds. Nothing for a session cookie
- -> m ()
-setEncryptedCookie n v p me = setEncryptedCookie' n v p me encryptCookie
-
-setEncryptedCookie' n v p me encFunc=
- modify $ \st -> st{mfCookies =
- (unsafePerformIO $ encFunc
- ( SB.fromString n,
- SB.fromString v,
- SB.fromString p,
- fmap (SB.fromString . show) me)):mfCookies st }
-
--- | Set an HTTP Response header
-setHttpHeader :: MonadState (MFlowState view) m
- => SB.ByteString -- ^ name
- -> SB.ByteString -- ^ value
- -> m ()
-setHttpHeader n v =
- modify $ \st -> st{mfHttpHeaders = nubBy (\ x y -> fst x == fst y) $ (n,v):mfHttpHeaders st}
-
-
--- | Set
--- 1) the timeout of the flow execution since the last user interaction.
--- Once passed, the flow executes from the begining.
---
--- 2) In persistent flows
--- it set the session state timeout for the flow, that is persistent. If the
--- flow is not persistent, it has no effect.
---
--- As the other state primitives, it can be run in the Flow and in the View monad
---
--- `transient` flows restart anew.
--- persistent flows (that use `step`) restart at the las saved execution point, unless
--- the session time has expired for the user.
-setTimeouts :: ( MonadState (MFlowState v) m) => Int -> Integer -> m ()
-setTimeouts kt st= do
- fs <- get
- put fs{ mfkillTime= kt, mfSessionTime= st}
-
-
-getWFName :: MonadState (MFlowState view) m => m String
-getWFName = do
- fs <- get
- return . twfname $ mfToken fs
-
-getCurrentUser :: MonadState (MFlowState view) m => m String
-getCurrentUser = do
- st<- gets mfToken
- return $ tuser st
-
-type Name= String
-type Type= String
-type Value= String
-type Checked= Bool
-type OnClick= Maybe String
-
-normalize :: (Monad m, FormInput v) => View v m a -> View B.ByteString m a
-normalize f= View . StateT $ \s ->do
- (FormElm fs mx, s') <- runStateT ( runView f) $ unsafeCoerce s
- return (FormElm (toByteString fs ) mx,unsafeCoerce s')
-
-
-
--- | Minimal interface for defining the basic form and link elements. The core of MFlow is agnostic
--- about the rendering package used. Every formatting (either HTML or not) used with MFlow must have an
--- instance of this class.
--- See "MFlow.Forms.Blaze.Html for the instance for blaze-html" "MFlow.Forms.XHtml" for the instance
--- for @Text.XHtml@ and MFlow.Forms.HSP for the instance for Haskell Server Pages.
-class (Monoid view,Typeable view) => FormInput view where
- toByteString :: view -> B.ByteString
- toHttpData :: view -> HttpData
- fromStr :: String -> view
- fromStrNoEncode :: String -> view
- ftag :: String -> view -> view
- inred :: view -> view
- flink :: String -> view -> view
- flink1:: String -> view
- flink1 verb = flink verb (fromStr verb)
- finput :: Name -> Type -> Value -> Checked -> OnClick -> view
- ftextarea :: String -> T.Text -> view
- fselect :: String -> view -> view
- foption :: String -> view -> Bool -> view
- foption1 :: String -> Bool -> view
- foption1 val msel= foption val (fromStr val) msel
- formAction :: String -> view -> view
- attrs :: view -> Attribs -> view
-
-
-
---instance (MonadIO m) => MonadIO (FlowM view m) where
--- liftIO io= let x= liftIO io in x `seq` lift x -- to force liftIO==unsafePerformIO onf the Identity monad
-
---instance Executable (View v m) where
--- execute f = execute $ evalStateT f mFlowState0
-
-
---instance (Monad m, Executable m, Monoid view, FormInput view)
--- => Executable (StateT (MFlowState view) m) where
--- execute f= execute $ evalStateT f mFlowState0
-
--- | Cached widgets operate with widgets in the Identity monad, but they may perform IO using the execute instance
--- of the monad m, which is usually the IO monad. execute basically \"sanctifies\" the use of unsafePerformIO for a transient purpose
--- such is caching. This is defined in "Data.TCache.Memoization". The programmer can create his
--- own instance for his monad.
---
--- With `cachedWidget` it is possible to cache the rendering of a widget as a ByteString (maintaining type safety)
---, permanently or for a certain time. this is very useful for complex widgets that present information. Specially it they must access to databases.
---
--- @
--- import MFlow.Wai.Blaze.Html.All
--- import Some.Time.Library
--- addMessageFlows [(noscript, time)]
--- main= run 80 waiMessageFlow
--- time=do ask $ cachedWidget \"time\" 5
--- $ wlink () b << \"the time is \" ++ show (execute giveTheTime) ++ \" click here\"
--- time
--- @
---
--- this pseudocode would update the time every 5 seconds. The execution of the IO computation
--- giveTheTime must be executed inside the cached widget to avoid unnecesary IO executions.
---
--- NOTE: the rendering of cached widgets are shared by all users
-cachedWidget :: (MonadIO m,Typeable view
- , FormInput view, Typeable a, Executable m )
- => String -- ^ The key of the cached object for the retrieval
- -> Int -- ^ Timeout of the caching. Zero means the whole server run
- -> View view Identity a -- ^ The cached widget, in the Identity monad
- -> View view m a -- ^ The cached result
-cachedWidget key t mf = View . StateT $ \s -> do
- let((FormElm form _), sec)= execute $! cachedByKey key t $ proc mf s{mfCached=True}
- let((FormElm _ mx2), s2) = execute $ runStateT ( runView mf) s{mfSeqCache= sec,mfCached=True}
- let s''= s{inSync = inSync s2
- ,mfRequirements=mfRequirements s2
+ -> m ()
+setEncryptedCookie n v p me = setEncryptedCookie' n v p me encryptCookie
+
+setEncryptedCookie' n v p me encFunc=
+ modify $ \st -> st{mfCookies =
+ (unsafePerformIO $ encFunc
+ ( SB.fromString n,
+ SB.fromString v,
+ SB.fromString p,
+ fmap (SB.fromString . show) me)):mfCookies st }
+
+-- | Set an HTTP Response header
+setHttpHeader :: MonadState (MFlowState view) m
+ => SB.ByteString -- ^ name
+ -> SB.ByteString -- ^ value
+ -> m ()
+setHttpHeader n v =
+ modify $ \st -> st{mfHttpHeaders = nubBy (\ x y -> fst x == fst y) $ (n,v):mfHttpHeaders st}
+
+
+-- | Set
+-- 1) the timeout of the flow execution since the last user interaction.
+-- Once passed, the flow executes from the begining.
+--
+-- 2) In persistent flows
+-- it set the session state timeout for the flow, that is persistent. If the
+-- flow is not persistent, it has no effect.
+--
+-- As the other state primitives, it can be run in the Flow and in the View monad
+--
+-- `transient` flows restart anew.
+-- persistent flows (that use `step`) restart at the las saved execution point, unless
+-- the session time has expired for the user.
+setTimeouts :: ( MonadState (MFlowState v) m) => Int -> Integer -> m ()
+setTimeouts kt st= do
+ fs <- get
+ put fs{ mfkillTime= kt, mfSessionTime= st}
+
+
+getWFName :: MonadState (MFlowState view) m => m String
+getWFName = do
+ fs <- get
+ return . twfname $ mfToken fs
+
+getCurrentUser :: MonadState (MFlowState view) m => m String
+getCurrentUser = do
+ st<- gets mfToken
+ return $ tuser st
+
+type Name= String
+type Type= String
+type Value= String
+type Checked= Bool
+type OnClick= Maybe String
+
+normalize :: (Monad m, FormInput v) => View v m a -> View B.ByteString m a
+normalize f= View . StateT $ \s ->do
+ (FormElm fs mx, s') <- runStateT ( runView f) $ unsafeCoerce s
+ return (FormElm (toByteString fs ) mx,unsafeCoerce s')
+
+
+
+-- | Minimal interface for defining the basic form and link elements. The core of MFlow is agnostic
+-- about the rendering package used. Every formatting (either HTML or not) used with MFlow must have an
+-- instance of this class.
+-- See "MFlow.Forms.Blaze.Html for the instance for blaze-html" "MFlow.Forms.XHtml" for the instance
+-- for @Text.XHtml@ and MFlow.Forms.HSP for the instance for Haskell Server Pages.
+class (Monoid view,Typeable view) => FormInput view where
+ toByteString :: view -> B.ByteString
+ toHttpData :: view -> HttpData
+ fromStr :: String -> view
+ fromStrNoEncode :: String -> view
+ ftag :: String -> view -> view
+ inred :: view -> view
+ flink :: String -> view -> view
+ flink1:: String -> view
+ flink1 verb = flink verb (fromStr verb)
+ finput :: Name -> Type -> Value -> Checked -> OnClick -> view
+ ftextarea :: String -> T.Text -> view
+ fselect :: String -> view -> view
+ foption :: String -> view -> Bool -> view
+ foption1 :: String -> Bool -> view
+ foption1 val msel= foption val (fromStr val) msel
+ formAction :: String -> String -> view -> view
+ attrs :: view -> Attribs -> view
+
+
+
+--instance (MonadIO m) => MonadIO (FlowM view m) where
+-- liftIO io= let x= liftIO io in x `seq` lift x -- to force liftIO==unsafePerformIO onf the Identity monad
+
+--instance Executable (View v m) where
+-- execute f = execute $ evalStateT f mFlowState0
+
+
+--instance (Monad m, Executable m, Monoid view, FormInput view)
+-- => Executable (StateT (MFlowState view) m) where
+-- execute f= execute $ evalStateT f mFlowState0
+
+-- | Cached widgets operate with widgets in the Identity monad, but they may perform IO using the execute instance
+-- of the monad m, which is usually the IO monad. execute basically \"sanctifies\" the use of unsafePerformIO for a transient purpose
+-- such is caching. This is defined in "Data.TCache.Memoization". The programmer can create his
+-- own instance for his monad.
+--
+-- With `cachedWidget` it is possible to cache the rendering of a widget as a ByteString (maintaining type safety)
+--, permanently or for a certain time. this is very useful for complex widgets that present information. Specially it they must access to databases.
+--
+-- @
+-- import MFlow.Wai.Blaze.Html.All
+-- import Some.Time.Library
+-- addMessageFlows [(noscript, time)]
+-- main= run 80 waiMessageFlow
+-- time=do ask $ cachedWidget \"time\" 5
+-- $ wlink () b << \"the time is \" ++ show (execute giveTheTime) ++ \" click here\"
+-- time
+-- @
+--
+-- this pseudocode would update the time every 5 seconds. The execution of the IO computation
+-- giveTheTime must be executed inside the cached widget to avoid unnecesary IO executions.
+--
+-- NOTE: the rendering of cached widgets are shared by all users
+cachedWidget :: (MonadIO m,Typeable view
+ , FormInput view, Typeable a, Executable m )
+ => String -- ^ The key of the cached object for the retrieval
+ -> Int -- ^ Timeout of the caching. Zero means the whole server run
+ -> View view Identity a -- ^ The cached widget, in the Identity monad
+ -> View view m a -- ^ The cached result
+cachedWidget key t mf = View . StateT $ \s -> do
+ let((FormElm form _), sec)= execute $! cachedByKey key t $ proc mf s{mfCached=True}
+ let((FormElm _ mx2), s2) = execute $ runStateT ( runView mf) s{mfSeqCache= sec,mfCached=True}
+ let s''= s{inSync = inSync s2
+ ,mfRequirements=mfRequirements s2
,mfPath= mfPath s2
- ,mfPagePath= mfPagePath s2
- ,needForm= needForm s2
- ,mfPageFlow= mfPageFlow s2
+ ,mfPagePath= mfPagePath s2
+ ,needForm= needForm s2
+ ,mfPageFlow= mfPageFlow s2
,mfSeqCache= mfSeqCache s + mfSeqCache s2 - sec}
return $ (mfSeqCache s'') `seq` form `seq` ((FormElm form mx2), s'')
-
- -- !> ("enter: "++show (mfSeqCache s) ++" exit: "++ show ( mfSeqCache s2))
- where
- proc mf s= runStateT (runView mf) s >>= \(r,_) -> mfSeqCache s `seq` return (r,mfSeqCache s )
-
--- | A shorter name for `cachedWidget`
-wcached :: (MonadIO m,Typeable view
- , FormInput view, Typeable a, Executable m )
- => String -- ^ The key of the cached object for the retrieval
- -> Int -- ^ Timeout of the caching. Zero means sessionwide
- -> View view Identity a -- ^ The cached widget, in the Identity monad
- -> View view m a -- ^ The cached result
-wcached= cachedWidget
-
--- | Unlike `cachedWidget`, which cache the rendering but not the user response, @wfreeze@
--- cache also the user response. This is useful for pseudo-widgets which just show information
--- while the controls are in other non freezed widgets. A freezed widget ever return the first user response
--- It is faster than `cachedWidget`.
--- It is not restricted to the Identity monad.
---
--- NOTE: the content of freezed widgets are shared by all users
-wfreeze :: (MonadIO m,Typeable view
- , FormInput view, Typeable a, Executable m )
- => String -- ^ The key of the cached object for the retrieval
- -> Int -- ^ Timeout of the caching. Zero means sessionwide
- -> View view m a -- ^ The cached widget
- -> View view m a -- ^ The cached result
-wfreeze key t mf = View . StateT $ \s -> do
- (FormElm f mx, req,seq,ajax) <- cachedByKey key t $ proc mf s{mfCached=True}
- return ((FormElm f mx), s{mfRequirements=req ,mfSeqCache= seq,mfAjax=ajax})
- where
- proc mf s= do
- (r,s) <- runStateT (runView mf) s
- return (r,mfRequirements s, mfSeqCache s, mfAjax s)
-
-
-
-{- | Execute the Flow, in the @FlowM view m@ monad. It is used as parameter of `hackMessageFlow`
-`waiMessageFlow` or `addMessageFlows`
-
-The flow is executed in a loop. When the flow is finished, it is started again
-
-@main= do
- addMessageFlows [(\"noscript\",transient $ runFlow mainf)]
- forkIO . run 80 $ waiMessageFlow
- adminLoop
-@
--}
-runFlow :: (FormInput view, MonadIO m)
- => FlowM view (Workflow m) () -> Token -> Workflow m ()
-runFlow f t=
- loop (startState t) f t
- where
- loop s f t = do
- (mt,s) <- runFlowOnce2 s f
- let t'= fromFailBack mt
- let t''= t'{tpath=[twfname t']}
- liftIO $ do
- flushRec t''
+
+ -- !> ("enter: "++show (mfSeqCache s) ++" exit: "++ show ( mfSeqCache s2))
+ where
+ proc mf s= runStateT (runView mf) s >>= \(r,_) -> mfSeqCache s `seq` return (r,mfSeqCache s )
+
+-- | A shorter name for `cachedWidget`
+wcached :: (MonadIO m,Typeable view
+ , FormInput view, Typeable a, Executable m )
+ => String -- ^ The key of the cached object for the retrieval
+ -> Int -- ^ Timeout of the caching. Zero means sessionwide
+ -> View view Identity a -- ^ The cached widget, in the Identity monad
+ -> View view m a -- ^ The cached result
+wcached= cachedWidget
+
+-- | Unlike `cachedWidget`, which cache the rendering but not the user response, @wfreeze@
+-- cache also the user response. This is useful for pseudo-widgets which just show information
+-- while the controls are in other non freezed widgets. A freezed widget ever return the first user response
+-- It is faster than `cachedWidget`.
+-- It is not restricted to the Identity monad.
+--
+-- NOTE: the content of freezed widgets are shared by all users
+wfreeze :: (MonadIO m,Typeable view
+ , FormInput view, Typeable a, Executable m )
+ => String -- ^ The key of the cached object for the retrieval
+ -> Int -- ^ Timeout of the caching. Zero means sessionwide
+ -> View view m a -- ^ The cached widget
+ -> View view m a -- ^ The cached result
+wfreeze key t mf = View . StateT $ \s -> do
+ (FormElm f mx, req,seq,ajax) <- cachedByKey key t $ proc mf s{mfCached=True}
+ return ((FormElm f mx), s{mfRequirements=req ,mfSeqCache= seq,mfAjax=ajax})
+ where
+ proc mf s= do
+ (r,s) <- runStateT (runView mf) s
+ return (r,mfRequirements s, mfSeqCache s, mfAjax s)
+
+
+
+{- | Execute the Flow, in the @FlowM view m@ monad. It is used as parameter of `hackMessageFlow`
+`waiMessageFlow` or `addMessageFlows`
+
+The flow is executed in a loop. When the flow is finished, it is started again
+
+@main= do
+ addMessageFlows [(\"noscript\",transient $ runFlow mainf)]
+ forkIO . run 80 $ waiMessageFlow
+ adminLoop
+@
+-}
+runFlow :: (FormInput view, MonadIO m)
+ => FlowM view (Workflow m) () -> Token -> Workflow m ()
+runFlow f t=
+ loop (startState t) f t
+ where
+ loop s f t = do
+ (mt,s) <- runFlowOnce2 s f
+ let t'= fromFailBack mt
+ let t''= t'{tpath=[twfname t']}
+ liftIO $ do
+ flushRec t''
sendToMF t'' t''
let s'= case mfSequence s of
-1 -> s -- !> "end of recovery loop"
- _ -> s{mfPath=[twfname t],mfPagePath=[],mfEnv=[]}
- loop s' f t''{tpath=[]} -- !> "LOOPAGAIN"
-
-inRecovery= -1
-
-runFlowOnce :: (FormInput view, MonadIO m)
- => FlowM view (Workflow m) () -> Token -> Workflow m ()
-runFlowOnce f t= runFlowOnce1 f t >> return ()
-
-runFlowOnce1 f t = runFlowOnce2 (startState t) f
-
+ _ -> s{mfPath=[twfname t],mfPagePath=[],mfEnv=[]}
+ loop s' f t''{tpath=[]} -- !> "LOOPAGAIN"
+
+inRecovery= -1
+
+runFlowOnce :: (FormInput view, MonadIO m)
+ => FlowM view (Workflow m) () -> Token -> Workflow m ()
+runFlowOnce f t= runFlowOnce1 f t >> return ()
+
+runFlowOnce1 f t = runFlowOnce2 (startState t) f
+
startState t= mFlowState0{mfToken=t
- ,mfSequence= inRecovery
- ,mfPath= tpath t
+ ,mfSequence= inRecovery
+ ,mfPath= tpath t
,mfEnv= tenv t
- ,mfPagePath=[]}
+ ,mfPagePath=[]}
-runFlowOnce2 s f =
- runStateT (runSup . runFlowM $ do
- backInit
- f
- getToken) s
-
-
- where
- backInit= do
- s <- get -- !> "BackInit"
- case mfTrace s of
+runFlowOnce2 s f =
+ runStateT (runSup . runFlowM $ do
+ backInit
+ f
+ getToken) s
+
+
+ where
+ backInit= do
+ s <- get -- !> "BackInit"
+ case mfTrace s of
[] -> do
let t = mfToken s
back <- goingBack
recover <- lift $ isInRecover
- when (back && not recover) . modify $ \s -> s{ newAsk= True,mfPagePath=[twfname t]}
+ when (back && not recover) . modify $ \s -> s{ newAsk= True,mfPagePath=[twfname t]}
breturn ()
-
- tr -> error $ disp tr
- where
- disp tr= "TRACE (error in the last line):\n\n" ++(concat $ intersperse "\n" tr)
- -- to restart the flow in case of going back before the first page of the flow
+
+ tr -> error $ disp tr
+ where
+ disp tr= "TRACE (error in the last line):\n\n" ++(concat $ intersperse "\n" tr)
+ -- to restart the flow in case of going back before the first page of the flow
runFlowOnceReturn
:: FormInput v => MFlowState v -> FlowM v m a -> Token -> m (FailBack a, MFlowState v)
-runFlowOnceReturn s f t =
- runStateT (runSup $ runFlowM f) (startState t)
-
-
-
--- | Run a persistent flow inside the current flow. It is identified by the procedure and
--- the string identifier.
--- unlike the normal flows, that run within infinite loops, runFlowIn executes once.
--- In subsequent executions, the flow will get the intermediate responses from te log
+runFlowOnceReturn s f t =
+ runStateT (runSup $ runFlowM f) (startState t)
+
+
+
+-- | Run a persistent flow inside the current flow. It is identified by the procedure and
+-- the string identifier.
+-- unlike the normal flows, that run within infinite loops, runFlowIn executes once.
+-- In subsequent executions, the flow will get the intermediate responses from te log
-- and will return the result without asking again.
-- This is useful for asking once, storing in the log and subsequently retrieving user
--- defined configurations by means of persistent flows with web formularies.
-runFlowIn
- :: (MonadIO m,
- FormInput view)
- => String
- -> FlowM view (Workflow IO) b
- -> FlowM view m b
-runFlowIn wf f= FlowM . Sup $ do
- st <- get
- let t = mfToken st
- (r,st') <- liftIO $ exec1nc wf $ runFlow1 st f t
- put st{mfPath= mfPath st'}
- case r of
- GoBack -> delWF wf ()
- return r
-
- where
- runFlow1 st f t= runStateT (runSup . runFlowM $ f) st
-
-
--- | to unlift a FlowM computation. useful for executing the configuration generated by runFLowIn
--- outside of the web flow (FlowM) monad
-runFlowConf :: (FormInput view, MonadIO m) => FlowM view m a -> m a
-runFlowConf f = do
- q <- liftIO newEmptyMVar -- `debug` (i++w++u)
+-- defined configurations by means of persistent flows with web formularies.
+runFlowIn
+ :: (MonadIO m,
+ FormInput view)
+ => String
+ -> FlowM view (Workflow IO) b
+ -> FlowM view m b
+runFlowIn wf f= FlowM . Sup $ do
+ st <- get
+ let t = mfToken st
+ (r,st') <- liftIO $ exec1nc wf $ runFlow1 st f t
+ put st{mfPath= mfPath st'}
+ case r of
+ GoBack -> delWF wf ()
+ return r
+
+ where
+ runFlow1 st f t= runStateT (runSup . runFlowM $ f) st
+
+
+-- | to unlift a FlowM computation. useful for executing the configuration generated by runFLowIn
+-- outside of the web flow (FlowM) monad
+runFlowConf :: (FormInput view, MonadIO m) => FlowM view m a -> m a
+runFlowConf f = do
+ q <- liftIO newEmptyMVar -- `debug` (i++w++u)
qr <- liftIO newEmptyMVar
- block <- liftIO $ newMVar True
- let t= Token "" "" "" [] [] block q qr
- evalStateT (runSup . runFlowM $ f ) mFlowState0{mfToken=t} >>= return . fromFailBack -- >> return ()
-
+ block <- liftIO $ newMVar True
+ let t= Token "" "" "" [] [] block q qr
+ evalStateT (runSup . runFlowM $ f ) mFlowState0{mfToken=t} >>= return . fromFailBack -- >> return ()
+
-- | run a transient Flow from the IO monad.
--runNav :: String -> FlowM Html IO () -> IO ()
--runNav ident f= exec1 ident $ runFlowOnce (transientNav f) undefined
-
-
--- | Clears the environment
-clearEnv :: MonadState (MFlowState view) m => m ()
-clearEnv= do
- st <- get
- put st{ mfEnv= []}
-
-
-
-instance (FormInput v,Serialize a)
- => Serialize (a,MFlowState v) where
- showp (x,s)= case mfDebug s of
- False -> showp x
- True -> showp(x, mfEnv s)
- readp= choice[nodebug, debug]
- where
- nodebug= readp >>= \x -> return (x, mFlowState0{mfSequence= inRecovery})
- debug= do
- (x,env) <- readp
- return (x,mFlowState0{mfEnv= env,mfSequence= inRecovery})
-
-
-
--- | stores the result of the flow in a persistent log. When restarted, it get the result
--- from the log and it does not execute it again. When no results are in the log, the computation
--- is executed. It is equivalent to 'Control.Workflow.step' but in the FlowM monad.
-step
- :: (Serialize a,
- Typeable view,
- FormInput view,
- MonadIO m,
- Typeable a) =>
- FlowM view m a
- -> FlowM view (Workflow m) a
-step f= do
- s <- get
- flowM $ Sup $ do
- (r,s') <- lift . WF.step $ runStateT (runSup $ runFlowM f) s
-
- -- when recovery of a workflow, the MFlow state is not considered
- when( mfSequence s' /= inRecovery) $ put s' -- !> (show $ mfSequence s') -- else put s{newAsk=True}
- return r
-
--- | to execute transient flows as if they were persistent
+
+
+-- | Clears the environment
+clearEnv :: MonadState (MFlowState view) m => m ()
+clearEnv= do
+ st <- get
+ put st{ mfEnv= []}
+
+
+
+instance (FormInput v,Serialize a)
+ => Serialize (a,MFlowState v) where
+ showp (x,s)= case mfDebug s of
+ False -> showp x
+ True -> showp(x, mfEnv s)
+ readp= choice[nodebug, debug]
+ where
+ nodebug= readp >>= \x -> return (x, mFlowState0{mfSequence= inRecovery})
+ debug= do
+ (x,env) <- readp
+ return (x,mFlowState0{mfEnv= env,mfSequence= inRecovery})
+
+
+
+-- | stores the result of the flow in a persistent log. When restarted, it get the result
+-- from the log and it does not execute it again. When no results are in the log, the computation
+-- is executed. It is equivalent to 'Control.Workflow.step' but in the FlowM monad.
+step
+ :: (Serialize a,
+ Typeable view,
+ FormInput view,
+ MonadIO m,
+ Typeable a) =>
+ FlowM view m a
+ -> FlowM view (Workflow m) a
+step f= do
+ s <- get
+ FlowM $ Sup $ do
+ (r,s') <- lift . WF.step $ runStateT (runSup $ runFlowM f) s
+
+ -- when recovery of a workflow, the MFlow state is not considered
+ when( mfSequence s' /= inRecovery) $ put s' -- !> (show $ mfSequence s') -- else put s{newAsk=True}
+ return r
+
+-- | to execute transient flows as if they were persistent
-- it can be used instead of step, but it does log nothing.
-- Thus, it is faster and convenient when no session state must be stored beyond the lifespan of
--- the server process.
---
--- > transient $ runFlow f === runFlow $ transientNav f
-transientNav
- :: (Serialize a,
- Typeable view,
- FormInput view,
- Typeable a) =>
- FlowM view IO a
- -> FlowM view (Workflow IO) a
-transientNav f= do
- s <- get
- flowM $ Sup $ do
- (r,s') <- lift . unsafeIOtoWF $ runStateT (runSup $ runFlowM f) s
- put s'
- return r
-
---stepWFRef
--- :: (Serialize a,
--- Typeable view,
--- FormInput view,
--- MonadIO m,
--- Typeable a) =>
--- FlowM view m a
--- -> FlowM view (Workflow m) (WFRef (FailBack a),a)
---stepWFRef f= do
--- s <- get
--- flowM $ Sup $ do
--- (r,s') <- lift . WF.stepWFRef $ runStateT (runSup $ runFlowM f) s
--- -- when recovery of a workflow, the MFlow state is not considered
--- when( mfSequence s' >0) $ put s'
--- return r
-
---step f= do
--- s <- get
--- flowM $ Sup $ do
--- (r,s') <- do
--- (br,s') <- runStateT (runSup $ runFlowM f) s
--- case br of
--- NoBack r -> WF.step $ return r
--- BackPoint r -> WF.step $ return r
--- GoBack -> undoStep
--- -- when recovery of a workflow, the MFlow state is not considered
--- when( mfSequence s' >0) $ put s'
--- return r
-
-
-
---stepDebug
--- :: (Serialize a,
--- Typeable view,
--- FormInput view,
--- Monoid view,
--- MonadIO m,
--- Typeable a) =>
--- FlowM view m a
--- -> FlowM view (Workflow m) a
---stepDebug f= Sup $ do
--- s <- get
--- (r, s') <- lift $ do
--- (r',stat)<- do
--- rec <- isInRecover
--- case rec of
--- True ->do (r', s'') <- getStep 0
--- return (r',s{mfEnv= mfEnv (s'' `asTypeOf`s)})
--- False -> return (undefined,s)
--- (r'', s''') <- WF.stepDebug $ runStateT (runSup f) stat >>= \(r,s)-> return (r, s)
--- return $ (r'' `asTypeOf` r', s''' )
--- put s'
--- return r
-
-
-
-data ParamResult v a= NoParam | NotValidated String v | Validated a deriving (Read, Show)
-
-valToMaybe (Validated x)= Just x
-valToMaybe _= Nothing
-
-isValidated (Validated x)= True
-isValidated _= False
-
-fromValidated (Validated x)= x
-fromValidated NoParam= error $ "fromValidated : NoParam"
-fromValidated (NotValidated s err)= error $ "fromValidated: NotValidated "++ s
-
-
-
-getParam1 :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v)
- => String -> Params -> m (ParamResult v a)
-getParam1 par req = case lookup par req of
- Just x -> readParam x
- Nothing -> return NoParam
+-- the server process.
+--
+-- > transient $ runFlow f === runFlow $ transientNav f
+transientNav
+ :: (Serialize a,
+ Typeable view,
+ FormInput view,
+ Typeable a) =>
+ FlowM view IO a
+ -> FlowM view (Workflow IO) a
+transientNav f= do
+ s <- get
+ FlowM $ Sup $ do
+ (r,s') <- lift . unsafeIOtoWF $ runStateT (runSup $ runFlowM f) s
+ put s'
+ return r
+
+--stepWFRef
+-- :: (Serialize a,
+-- Typeable view,
+-- FormInput view,
+-- MonadIO m,
+-- Typeable a) =>
+-- FlowM view m a
+-- -> FlowM view (Workflow m) (WFRef (FailBack a),a)
+--stepWFRef f= do
+-- s <- get
+-- flowM $ Sup $ do
+-- (r,s') <- lift . WF.stepWFRef $ runStateT (runSup $ runFlowM f) s
+-- -- when recovery of a workflow, the MFlow state is not considered
+-- when( mfSequence s' >0) $ put s'
+-- return r
+
+--step f= do
+-- s <- get
+-- flowM $ Sup $ do
+-- (r,s') <- do
+-- (br,s') <- runStateT (runSup $ runFlowM f) s
+-- case br of
+-- NoBack r -> WF.step $ return r
+-- BackPoint r -> WF.step $ return r
+-- GoBack -> undoStep
+-- -- when recovery of a workflow, the MFlow state is not considered
+-- when( mfSequence s' >0) $ put s'
+-- return r
+
+
+
+--stepDebug
+-- :: (Serialize a,
+-- Typeable view,
+-- FormInput view,
+-- Monoid view,
+-- MonadIO m,
+-- Typeable a) =>
+-- FlowM view m a
+-- -> FlowM view (Workflow m) a
+--stepDebug f= Sup $ do
+-- s <- get
+-- (r, s') <- lift $ do
+-- (r',stat)<- do
+-- rec <- isInRecover
+-- case rec of
+-- True ->do (r', s'') <- getStep 0
+-- return (r',s{mfEnv= mfEnv (s'' `asTypeOf`s)})
+-- False -> return (undefined,s)
+-- (r'', s''') <- WF.stepDebug $ runStateT (runSup f) stat >>= \(r,s)-> return (r, s)
+-- return $ (r'' `asTypeOf` r', s''' )
+-- put s'
+-- return r
+
+
+
+data ParamResult v a= NoParam | NotValidated String v | Validated a deriving (Read, Show)
+
+valToMaybe (Validated x)= Just x
+valToMaybe _= Nothing
+
+isValidated (Validated x)= True
+isValidated _= False
+
+fromValidated (Validated x)= x
+fromValidated NoParam= error $ "fromValidated : NoParam"
+fromValidated (NotValidated s err)= error $ "fromValidated: NotValidated "++ s
+
+
+
+getParam1 :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v)
+ => String -> Params -> m (ParamResult v a)
+getParam1 par req = case lookup par req of
+ Just x -> readParam x
+ Nothing -> return NoParam
-- Read a segment in the REST path. if it does not match with the type requested
--- or if there is no remaining segment, it returns Nothing
+-- or if there is no remaining segment, it returns Nothing
getRestParam :: (Read a, Typeable a, Monad m, Functor m, MonadState (MFlowState v) m, FormInput v)
- => m (Maybe a)
-getRestParam= do
- st <- get
- let lpath = mfPath st
+ => m (Maybe a)
+getRestParam= do
+ st <- get
+ let lpath = mfPath st
if linkMatched st
- then return Nothing
+ then return Nothing
else case stripPrefix (mfPagePath st) lpath of
Nothing -> return Nothing
- Just [] -> return Nothing
- Just xs ->
- case stripPrefix (mfPrefix st) (head xs) of
- Nothing -> return Nothing
- Just name -> do
- r <- fmap valToMaybe $ readParam name
- when (isJust r) $ modify $ \s -> s{inSync= True
- ,linkMatched= True
- ,mfPagePath= mfPagePath s++[name]}
- return r
-
+ Just [] -> return Nothing
+ Just xs -> do
+-- case stripPrefix (mfPrefix st) (head xs) of
+-- Nothing -> return Nothing
+-- Just name ->
+ let name= head xs
+ r <- fmap valToMaybe $ readParam name
+ when (isJust r) $ modify $ \s -> s{inSync= True
+ ,linkMatched= True
+ ,mfPagePath= mfPagePath s++[name]}
+ return r
+
-- | return the value of a post or get param in the form ?param=value&param2=value2...
@@ -1246,31 +1284,31 @@
st <- get
r <- getParam1 par $ mfEnv st
return $ valToMaybe r
-
-readParam :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v)
- => String -> m (ParamResult v a)
-readParam x1 = r
- where
- r= do
- modify $ \s -> s{inSync= True}
- maybeRead x1
-
- getType :: m (ParamResult v a) -> a
- getType= undefined
- x= getType r
- maybeRead str= do
- let typeofx = typeOf x
+
+readParam :: (Monad m, MonadState (MFlowState v) m, Typeable a, Read a, FormInput v)
+ => String -> m (ParamResult v a)
+readParam x1 = r
+ where
+ r= do
+ modify $ \s -> s{inSync= True}
+ maybeRead x1
+
+ getType :: m (ParamResult v a) -> a
+ getType= undefined
+ x= getType r
+ maybeRead str= do
+ let typeofx = typeOf x
if typeofx == typeOf ( undefined :: String) then
return . Validated $ unsafeCoerce str
else if typeofx == typeOf (undefined :: T.Text) then
- return . Validated . unsafeCoerce $ T.pack str
- else case readsPrec 0 $ str of
- [(x,"")] -> return $ Validated x
- _ -> do
- let err= inred . fromStr $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x)
- return $ NotValidated str err
-
-
+ return . Validated . unsafeCoerce $ T.pack str
+ else case readsPrec 0 $ str of
+ [(x,"")] -> return $ Validated x
+ _ -> do
+ let err= inred . fromStr $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x)
+ return $ NotValidated str err
+
+
---- Requirements
@@ -1278,39 +1316,41 @@
-- Web page or in the server when a widget specifies this. @requires@ is the
-- procedure to be called with the list of requirements.
-- Various widgets in the page can require the same element, MFlow will install it once.
+
+
requires rs =do
st <- get
let l = mfRequirements st
--- let rs'= map Requirement rs \\ l
put st {mfRequirements= l ++ map Requirement rs}
-
+unfold (JScriptFile f ss)= JScript loadScript:map (\s-> JScriptFile f [s]) ss
+unfold x= [x]
data Requirement= forall a.(Show a,Typeable a,Requirements a) => Requirement a deriving Typeable
class Requirements a where
- installRequirements :: (Monad m,FormInput view) => Bool -> [a] -> m view
+ installRequirements :: (MonadState (MFlowState view) m,MonadIO m,FormInput view) => [a] -> m view
instance Show Requirement where
show (Requirement a)= show a ++ "\n"
-installAllRequirements :: ( Monad m, FormInput view) => WState view m view
+installAllRequirements :: ( MonadIO m, FormInput view) => WState view m view
installAllRequirements= do
st <- get
let rs = mfRequirements st
- auto = mfAutorefresh st
- installAllRequirements1 auto mempty rs
+ installAllRequirements1 mempty rs
+
where
- installAllRequirements1 _ v []= return v
- installAllRequirements1 auto v rs= do
+ installAllRequirements1 v []= return v
+ installAllRequirements1 v rs= do
let typehead= case head rs of {Requirement r -> typeOf r}
(rs',rs'')= partition1 typehead rs
v' <- installRequirements2 rs'
- installAllRequirements1 auto (v `mappend` v') rs''
+ installAllRequirements1 (v `mappend` v') rs''
where
installRequirements2 []= return $ fromStrNoEncode ""
- installRequirements2 (Requirement r:rs)= installRequirements auto $ r:unmap rs
+ installRequirements2 (Requirement r:rs)= installRequirements $ r:unmap rs
unmap []=[]
unmap (Requirement r:rs)= unsafeCoerce r:unmap rs
partition1 typehead xs = foldr select ([],[]) xs
@@ -1320,155 +1360,194 @@
in if typer== typehead then ( x:ts,fs)
else (ts, x:fs)
--- Web requirements ---
-loadjsfile filename lcallbacks=
- let name= addrStr filename in
- "var fileref = document.getElementById('"++name++"');\
- \if (fileref === null){\
+-- Web requirements ---
+loadjsfile filename=
+ let name= addrStr filename
+ in "\n"++name++"=loadScript('"++name++"','"++filename++"');\n"
+
+loadScript ="function loadScript(name, filename){\
+ \var fileref = document.getElementById(name);\
+ \if (fileref === null){\
\fileref=document.createElement('script');\
- \fileref.setAttribute('id','"++name++"');\
- \fileref.setAttribute('type','text/javascript');\
- \fileref.setAttribute('src',\'" ++ filename ++ "\');\
- \document.getElementsByTagName('head')[0].appendChild(fileref);};"
- ++ onload
- where
- onload= case lcallbacks of
- [] -> ""
- cs -> "fileref.onload = function() {"++ (concat $ nub cs)++"};"
-
-
-loadjs content= content
-
-
-loadcssfile filename=
- "var fileref=document.createElement('link');\
- \fileref.setAttribute('rel', 'stylesheet');\
- \fileref.setAttribute('type', 'text/css');\
- \fileref.setAttribute('href', \'"++filename++"\');\
- \document.getElementsByTagName('head')[0].appendChild(fileref);"
-
-
-loadcss content=
- "var fileref=document.createElement('link');\
- \fileref.setAttribute('rel', 'stylesheet');\
- \fileref.setAttribute('type', 'text/css');\
- \fileref.innerText=\""++content++"\";\
- \document.getElementsByTagName('head')[0].appendChild(fileref);"
-
-
-data WebRequirement= JScriptFile
- String
- [String] -- ^ Script URL and the list of scripts to be executed when loaded
- | CSSFile String -- ^ a CSS file URL
- | CSS String -- ^ a String with a CSS description
- | JScript String -- ^ a string with a valid JavaScript
- | ServerProc (String, Flow) -- ^ a server procedure
- deriving(Typeable,Eq,Ord,Show)
-
-instance Eq (String, Flow) where
+ \fileref.setAttribute('id',name);\
+ \fileref.setAttribute('type','text/javascript');\
+ \fileref.setAttribute('src',filename);\
+ \document.getElementsByTagName('head')[0].appendChild(fileref);}\
+ \return fileref};\n\
+ \function addLoadEvent(elem,func) {\
+ \var oldonload = elem.onload;\
+ \if (typeof elem.onload != 'function') {\
+ \elem.onload = func;\
+ \} else {\
+ \elem.onload = function() {\
+ \if (oldonload) {\
+ \oldonload();\
+ \}\
+ \func();\
+ \}\
+ \}\
+ \}"
+
+loadCallback depend script=
+ let varname= addrStr depend in
+ "\naddLoadEvent("++varname++",function(){"++ script++"});"
+
+
+
+
+loadcssfile filename=
+ "var fileref=document.createElement('link');\
+ \fileref.setAttribute('rel', 'stylesheet');\
+ \fileref.setAttribute('type', 'text/css');\
+ \fileref.setAttribute('href', \'"++filename++"\');\
+ \document.getElementsByTagName('head')[0].appendChild(fileref);"
+
+
+loadcss content=
+ "var fileref=document.createElement('link');\
+ \fileref.setAttribute('rel', 'stylesheet');\
+ \fileref.setAttribute('type', 'text/css');\
+ \fileref.innerText=\""++content++"\";\
+ \document.getElementsByTagName('head')[0].appendChild(fileref);"
+
+
+data WebRequirement= JScriptFile
+ String
+ [String] -- ^ Script URL and the list of scripts to be executed when loaded
+ | CSSFile String -- ^ a CSS file URL
+ | CSS String -- ^ a String with a CSS description
+ | JScript String -- ^ a string with a valid JavaScript
+ | ServerProc (String, Flow) -- ^ a server procedure
+ deriving(Typeable,Eq,Ord,Show)
+
+instance Eq (String, Flow) where
(x,_) == (y,_)= x == y
-
-instance Ord (String, Flow) where
- compare(x,_) (y,_)= compare x y
-instance Show (String, Flow) where
- show (x,_)= show x
-
-instance Requirements WebRequirement where
- installRequirements= installWebRequirements
-
-
-
-installWebRequirements :: (Monad m,FormInput view) => Bool -> [WebRequirement] -> m view
-installWebRequirements auto rs= do
- let s = jsRequirements auto $ sort rs
-
- return $ ftag "script" (fromStrNoEncode s)
-
-
-jsRequirements _ []= ""
-
-jsRequirements False (r@(JScriptFile f c) : r'@(JScriptFile f' c'):rs)
- | f==f' = jsRequirements False $ JScriptFile f (nub $ c++c'):rs
- | otherwise= strRequirement r ++ jsRequirements False (r':rs)
-
-jsRequirements True (r@(JScriptFile f c) : r'@(JScriptFile f' c'):rs)
- | f==f' = concatMap strRequirement(map JScript $ nub (c' ++ c)) ++ jsRequirements True rs
- | otherwise= strRequirement r ++ jsRequirements True (r':rs)
-
-
-
-
-jsRequirements auto (r:r':rs)
- | r== r' = jsRequirements auto $ r:rs
- | otherwise= strRequirement r ++ jsRequirements auto (r':rs)
-
-jsRequirements auto (r:rs)= strRequirement r++jsRequirements auto rs
-
-strRequirement (CSSFile s') = loadcssfile s'
-strRequirement (CSS s') = loadcss s'
-strRequirement (JScriptFile s' call) = loadjsfile s' call
-strRequirement (JScript s') = loadjs s'
-strRequirement (ServerProc f)= (unsafePerformIO $! addMessageFlows [f]) `seq` ""
-
-
-
-
-
---- AJAX ----
-ajaxScript=
- "function loadXMLObj()" ++
- "{" ++
- "var xmlhttp;" ++
- "if (window.XMLHttpRequest)" ++
- "{"++
- " xmlhttp=new XMLHttpRequest();" ++
- " }" ++
- "else" ++
- "{"++
- " xmlhttp=new ActiveXObject('Microsoft.XMLHTTP');" ++
- " }" ++
- "return xmlhttp" ++
- "};" ++
-
- " xmlhttp= loadXMLObj();" ++
- " noparam= '';"++
- ""++
- "function doServer (servproc,param,param2){" ++
- " xmlhttp.open('GET',servproc+'?ajax='+param+'&val='+param2,true);" ++
- " xmlhttp.send();};" ++
- ""++
- "xmlhttp.onreadystatechange=function()" ++
- " {" ++
- " if (xmlhttp.readyState== 4 && xmlhttp.status==200)" ++
- " {" ++
- " eval(xmlhttp.responseText);" ++
- " }" ++
- " };" ++
- ""
-
-formPrefix st form anchored= do
+
+instance Ord (String, Flow) where
+ compare(x,_) (y,_)= compare x y
+instance Show (String, Flow) where
+ show (x,_)= show x
+
+instance Requirements WebRequirement where
+ installRequirements= installWebRequirements
+
+
+
+installWebRequirements
+ :: (MonadState(MFlowState view) m,MonadIO m,FormInput view) => [WebRequirement] -> m view
+installWebRequirements rs= do
+ installed <- gets mfInstalledScripts
+ let rs'= (nub rs) \\ installed
+
+ strs <- mapM strRequirement rs' -- !>( "OLD="++show installed) !> ("new="++show rs')
+ case null strs of
+ True -> return mempty
+ False -> return . ftag "script" . fromStrNoEncode $ concat strs
+
+
+strRequirement r=do
+ r1 <- strRequirement' r
+ modify $ \st -> st{mfInstalledScripts= mfInstalledScripts st ++ [r]}
+ return r1
+
+strRequirement' (CSSFile scr) = return $ loadcssfile scr
+strRequirement' (CSS scr) = return $ loadcss scr
+strRequirement' (JScriptFile file scripts) = do
+ installed <- gets mfInstalledScripts
+ let hasLoadScript (JScriptFile _ _)= True
+ hasLoadScript _= False
+ inst2= dropWhile (not . hasLoadScript) installed
+ hasSameFile file (JScriptFile fil _)= if file== fil then True else False
+ hasSameFile _ _= False
+ case (inst2,find (hasSameFile file) inst2) of
+ ([],_) ->
+ -- no script file has been loaded previously
+ return $ loadScript <> loadjsfile file <> concatMap(loadCallback file) scripts
+ (_,Just _) -> do
+ -- This script file has been already loaded or demanded for load
+ autorefresh <- gets mfAutorefresh
+ case autorefresh of
+ -- demanded for load, not loaded
+ False -> return $ concatMap(loadCallback file) scripts
+ -- already loaded
+ True -> return $ concat scripts
+ -- other script file has been loaded or demanded load, so loadScript is already installed
+ _ -> return $ loadjsfile file <> concatMap(loadCallback file) scripts
+
+
+strRequirement' (JScript scr) = return scr
+strRequirement' (ServerProc f)= do
+ liftIO $ addMessageFlows [f]
+ return ""
+
+
+
+
+
+--- AJAX ----
+ajaxScript=
+ "function loadXMLObj()" ++
+ "{" ++
+ "var xmlhttp;" ++
+ "if (window.XMLHttpRequest)" ++
+ "{"++
+ " xmlhttp=new XMLHttpRequest();" ++
+ " }" ++
+ "else" ++
+ "{"++
+ " xmlhttp=new ActiveXObject('Microsoft.XMLHTTP');" ++
+ " }" ++
+ "return xmlhttp" ++
+ "};" ++
+
+ " xmlhttp= loadXMLObj();" ++
+ " noparam= '';"++
+ ""++
+ "function doServer (servproc,param,param2){" ++
+ " xmlhttp.open('GET',servproc+'?ajax='+param+'&val='+param2,true);" ++
+ " xmlhttp.send();};" ++
+ ""++
+ "xmlhttp.onreadystatechange=function()" ++
+ " {" ++
+ " if (xmlhttp.readyState== 4 && xmlhttp.status==200)" ++
+ " {" ++
+ " eval(xmlhttp.responseText);" ++
+ " }" ++
+ " };" ++
+ ""
+
+formPrefix st form anchored= do
let verb = twfname $ mfToken st
- path = currentPath st
- (anchor,anchorf)
- <- case anchored of
- True -> do
- anchor <- genNewId
- return ('#':anchor, (ftag "a") mempty `attrs` [("name",anchor)])
- False -> return (mempty,mempty)
- return $ formAction (path ++ anchor ) $ anchorf <> form -- !> anchor
-
--- | insert a form tag if the widget has form input fields. If not, it does nothing
-insertForm w=View $ do
- FormElm forms mx <- runView w
- st <- get
- cont <- case needForm1 st of
- True -> do
- frm <- formPrefix st forms False
- put st{needForm= HasForm}
- return frm
- _ -> return forms
-
- return $ FormElm cont mx
+ path = currentPath st
+ hasfile= mfFileUpload st
+ attr= case hasfile of
+ True -> [("enctype","multipart/form-data")]
+ False -> []
+ (anchor,anchorf)
+ <- case anchored of
+ True -> do
+ anchor <- genNewId
+ return ('#':anchor, (ftag "a") mempty `attrs` [("name",anchor)])
+ False -> return (mempty,mempty)
+ return $ formAction (path ++ anchor ) "POST" ( anchorf <> form ) `attrs` attr
+
+
+
+
+
+
+-- | insert a form tag if the widget has form input fields. If not, it does nothing
+insertForm w=View $ do
+ FormElm forms mx <- runView w
+ st <- get
+ cont <- case needForm st of
+ HasElems -> do
+ frm <- formPrefix st forms False
+ put st{needForm= HasForm}
+ return frm
+ _ -> return forms
+
+ return $ FormElm cont mx
-- isert a form tag if necessary when two pieces of HTML have to mix as a result of >>= >> <|> or <+> operators
controlForms :: (FormInput v, MonadState (MFlowState v) m)
@@ -1481,40 +1560,40 @@
v1' <- formPrefix s1 v1 True
return (v1' <> v2 , True)
- _ -> return (v1 <> v2, False)
-
-currentPath st= concat ['/':v| v <- mfPagePath st ]
-
--- | Generate a new string. Useful for creating tag identifiers and other attributes.
---
--- if the page is refreshed, the identifiers generated are the same.
-genNewId :: MonadState (MFlowState view) m => m String
-genNewId= do
- st <- get
- case mfCached st of
- False -> do
- let n= mfSequence st
- prefseq= mfPrefix st
- put $ st{mfSequence= n+1}
-
- return $ 'p':show n++prefseq
- True -> do
- let n = mfSeqCache st
- put $ st{mfSeqCache=n+1}
- return $ 'c' : (show n)
-
--- | get the next ideitifier that will be created by genNewId
-getNextId :: MonadState (MFlowState view) m => m String
-getNextId= do
- st <- get
- case mfCached st of
- False -> do
- let n= mfSequence st
- prefseq= mfPrefix st
- return $ 'p':show n++prefseq
- True -> do
- let n = mfSeqCache st
- return $ 'c' : (show n)
+ _ -> return (v1 <> v2, False)
+
+currentPath st= concat ['/':v| v <- mfPagePath st ]
+
+-- | Generate a new string. Useful for creating tag identifiers and other attributes.
+--
+-- if the page is refreshed, the identifiers generated are the same.
+genNewId :: MonadState (MFlowState view) m => m String
+genNewId= do
+ st <- get
+ case mfCached st of
+ False -> do
+ let n= mfSequence st
+ prefseq= mfPrefix st
+ put $ st{mfSequence= n+1}
+
+ return $ 'p':show n++prefseq
+ True -> do
+ let n = mfSeqCache st
+ put $ st{mfSeqCache=n+1}
+ return $ 'c' : (show n)
+
+-- | get the next ideitifier that will be created by genNewId
+getNextId :: MonadState (MFlowState view) m => m String
+getNextId= do
+ st <- get
+ case mfCached st of
+ False -> do
+ let n= mfSequence st
+ prefseq= mfPrefix st
+ return $ 'p':show n++prefseq
+ True -> do
+ let n = mfSeqCache st
+ return $ 'c' : (show n)
+
-
diff -ru orig/src/MFlow/Forms/Test.hs new/src/MFlow/Forms/Test.hs
--- orig/src/MFlow/Forms/Test.hs 2014-06-10 05:51:26.977015856 +0300
+++ new/src/MFlow/Forms/Test.hs 2014-06-10 05:51:25.000000000 +0300
@@ -1,404 +1,404 @@
------------------------------------------------------------------------------
---
--- Module : MFlow.Forms.Test
--- Copyright :
--- License : BSD3
---
--- Maintainer : agocorona@gmail.com
--- Stability : experimental
--- Portability :
---
--- |
---
------------------------------------------------------------------------------
-{-# OPTIONS
- -XOverlappingInstances
- -XFlexibleInstances
- -XUndecidableInstances
- -XPatternGuards
- -XRecordWildCards
- #-}
-
-module MFlow.Forms.Test (Generate(..),runTest,runTest1,inject, ask, askt, userWidget, getUser, getUserSimple, verify) where
-import MFlow.Forms hiding(ask,askt,getUser,userWidget,getUserSimple)
-import qualified MFlow.Forms (ask)
-import MFlow.Forms.Internals
-import MFlow.Forms(FormInput(..))
-import MFlow.Forms.Admin
-import Control.Workflow as WF
-import Control.Concurrent
-import Control.Monad
-import MFlow
-import qualified Data.Map as M
-import Control.Monad.Trans
-import System.IO.Unsafe
-import System.Random
-import Data.Char(chr, ord)
-import Data.List
-import Data.Typeable
-import qualified Data.ByteString.Lazy.Char8 as B
-import Control.Concurrent.MVar
-import Data.TCache.Memoization
-import Control.Monad.State
-import Data.Monoid
-import Data.Maybe
-import Data.IORef
-import MFlow.Cookies(cookieuser)
-
-import Data.Dynamic
-import Data.TCache.Memoization
-
-
-
-class Generate a where
- generate :: IO a
-
-instance Generate a => Generate (Maybe a) where
- generate= do
- b <- randomRIO(0,1 :: Int)
- case b of 0 -> generate >>= return . Just ; _ -> return Nothing
-
-instance Generate String where
- generate= replicateM 5 $ randomRIO ('a','z')
-
-instance Generate Int where
- generate= randomRIO(1,1000)
-
-instance Generate Integer where
- generate= randomRIO(1,1000)
-
-
-instance (Generate a, Generate b) => Generate (a,b) where
- generate= fmap (,) generate `ap` generate
-
-
-instance (Generate a, Generate b) => Generate (Maybe a,Maybe b) where
- generate= do
- r <- generate
- case r of
- (Nothing,Nothing) -> generate
- other -> return other
-
-
-instance (Bounded a, Enum a) => Generate a where
- generate= mx
- where
- mx= do
- let x= typeOfIO mx
- n <- randomRIO ( fromEnum $ minBound `asTypeOf` x
- , fromEnum $ maxBound `asTypeOf` x)
- return $ toEnum n
- where
- typeOfIO :: IO a -> a
- typeOfIO = undefined
-
--- | run a list of flows with a number of simultaneous threads
-runTest :: [(Int, Flow)] -> IO ()
-runTest ps= do
- mapM_ (forkIO . run1) ps
- putStrLn $ "started " ++ (show . sum . fst $ unzip ps) ++ " threads"
-
- where
- run1 (nusers, proc) = replicateM_ nusers $ runTest1 proc
-
-runTest1 f = do
- atomicModifyIORef testNumber (\n -> (n+1,n+1))
- name <- generate
- x <- generate
- y <- generate
+-----------------------------------------------------------------------------
+--
+-- Module : MFlow.Forms.Test
+-- Copyright :
+-- License : BSD3
+--
+-- Maintainer : agocorona@gmail.com
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+{-# OPTIONS
+ -XOverlappingInstances
+ -XFlexibleInstances
+ -XUndecidableInstances
+ -XPatternGuards
+ -XRecordWildCards
+ #-}
+
+module MFlow.Forms.Test (Generate(..),runTest,runTest1,inject, ask, askt, userWidget, getUser, getUserSimple, verify) where
+import MFlow.Forms hiding(ask,askt,getUser,userWidget,getUserSimple)
+import qualified MFlow.Forms (ask)
+import MFlow.Forms.Internals
+import MFlow.Forms(FormInput(..))
+import MFlow.Forms.Admin
+import Control.Workflow as WF
+import Control.Concurrent
+import Control.Monad
+import MFlow
+import qualified Data.Map as M
+import Control.Monad.Trans
+import System.IO.Unsafe
+import System.Random
+import Data.Char(chr, ord)
+import Data.List
+import Data.Typeable
+import qualified Data.ByteString.Lazy.Char8 as B
+import Control.Concurrent.MVar
+import Data.TCache.Memoization
+import Control.Monad.State
+import Data.Monoid
+import Data.Maybe
+import Data.IORef
+import MFlow.Cookies(cookieuser)
+
+import Data.Dynamic
+import Data.TCache.Memoization
+
+
+
+class Generate a where
+ generate :: IO a
+
+instance Generate a => Generate (Maybe a) where
+ generate= do
+ b <- randomRIO(0,1 :: Int)
+ case b of 0 -> generate >>= return . Just ; _ -> return Nothing
+
+instance Generate String where
+ generate= replicateM 5 $ randomRIO ('a','z')
+
+instance Generate Int where
+ generate= randomRIO(1,1000)
+
+instance Generate Integer where
+ generate= randomRIO(1,1000)
+
+
+instance (Generate a, Generate b) => Generate (a,b) where
+ generate= fmap (,) generate `ap` generate
+
+
+instance (Generate a, Generate b) => Generate (Maybe a,Maybe b) where
+ generate= do
+ r <- generate
+ case r of
+ (Nothing,Nothing) -> generate
+ other -> return other
+
+
+instance (Bounded a, Enum a) => Generate a where
+ generate= mx
+ where
+ mx= do
+ let x= typeOfIO mx
+ n <- randomRIO ( fromEnum $ minBound `asTypeOf` x
+ , fromEnum $ maxBound `asTypeOf` x)
+ return $ toEnum n
+ where
+ typeOfIO :: IO a -> a
+ typeOfIO = undefined
+
+-- | run a list of flows with a number of simultaneous threads
+runTest :: [(Int, Flow)] -> IO ()
+runTest ps= do
+ mapM_ (forkIO . run1) ps
+ putStrLn $ "started " ++ (show . sum . fst $ unzip ps) ++ " threads"
+
+ where
+ run1 (nusers, proc) = replicateM_ nusers $ runTest1 proc
+
+runTest1 f = do
+ atomicModifyIORef testNumber (\n -> (n+1,n+1))
+ name <- generate
+ x <- generate
+ y <- generate
z <- generate
-
- let t = Token x y z [] [] undefined undefined undefined
- WF.start name f t
-
-testNumber= unsafePerformIO $ newIORef 0
-
-getTestNumber :: MonadIO m => m Int
-getTestNumber= liftIO $ readIORef testNumber
-
--- | inject substitutes an expression by other. It may be used to override
--- ask interaction with the user. It should bee used infix for greater readability:
---
--- > ask something `inject` const someother
---
--- The parameter passed is the test number
--- if the flow has not been executed by runTest, inject return the original
-inject :: MonadIO m => m b -> (Int -> b) -> m b
-inject exp v= do
- n <- getTestNumber
- if n== 0 then exp else exp `seq` return $ v n
-
--- | a simulated ask that generate simulated user input of the type expected.
---
--- It forces the web page rendering, since it is monadic and can contain
--- side effects and load effects to be tested.
---
--- it is a substitute of 'ask' from "MFlow.Forms" for testing purposes.
-
--- execute 'runText' to initiate threads under different load conditions.
-ask :: (Generate a, MonadIO m, Functor m, FormInput v,Typeable v) => View v m a -> FlowM v m a
-ask w = do
- FormElm forms mx <- FlowM . lift $ runView w
- r <- liftIO generate
- let n= B.length $ toByteString forms
- breturn $ n `seq` mx `seq` r
--- let u= undefined
--- liftIO $ runStateT (runView mf) s
--- bool <- liftIO generate
--- case bool of
--- False -> fail ""
--- True -> do
--- b <- liftIO generate
--- r <- liftIO generate
--- case (b,r) of
--- (True,x) -> breturn x
--- _ -> ask w
-
-
--- | instead of generating a result like `ask`, the result is given as the first parameter
--- so it does not need a Generate instance.
---
--- It forces the web page rendering, since it is monadic so it can contain
--- side effects and load effects to be tested.
-askt :: (MonadIO m, FormInput v) => (Int -> a) -> View v m a -> FlowM v m a
-askt v w = do
- FormElm forms mx <- FlowM . lift $ runView w
- n <- getTestNumber
- let l= B.length $ toByteString forms
- breturn $ l `seq` mx `seq` v n
-
---mvtestopts :: MVar (M.Map String (Int,Dynamic))
---mvtestopts = unsafePerformIO $ newMVar M.empty
-
---asktn :: (Typeable a,MonadIO m) => [a] -> View v m a -> FlowM v m a
---asktn xs w= do
--- v <- liftIO $ do
--- let k = addrStr xs
--- opts <- takeMVar mvtestopts
--- let r = M.lookup k opts
--- case r of
--- Nothing -> do
--- putMVar mvtestopts $ M.singleton k (0,toDyn xs)
--- return $ head xs
--- Just (i,d) -> do
--- putMVar mvtestopts $ M.insert k (i+1,d) opts
--- return $ (fromMaybe (error err1) $ fromDynamic d) !! i
---
--- askt v w
---
--- where
--- err1= "MFlow.Forms.Test: asktn: fromDynamic error"
-
-
--- | verify a property. if not true, throw the error message.
---
--- It is intended to be used in a infix notation, on the right of the code,
--- in order to separate the code assertions from the application code and make clearly
--- visible them as a form of documentation.
--- separated from it:
---
--- > liftIO $ print (x :: Int) `verify` (return $ x > 10, "x < = 10")
---
--- the expression is monadic to allow for complex verifications that may involve IO actions
-verifyM :: Monad m => m b -> (m Bool, String) -> m b
-verifyM f (mprop, msg)= do
- prop <- mprop
- case prop of
- True -> f
- False -> error msg
-
--- | a pure version of verifyM
-verify :: a -> (Bool, String) -> a
-verify f (prop, msg)= do
- case prop of
- True -> f
- False -> error msg
-
-
---
---match form=do
--- marches <- readIORef matches
--- return $ head map (m s) matches
--- where
--- m s (ms,ps) = case and $ map (flip isInfixOf $ s) ms of
--- True -> Just ps
--- False -> Nothing
---
---composeParams (Gen ps) form= zip (getParams form) ps
--- where
--- getParams form=
--- let search name form
--- | null form = mempty
--- | isPrefix name form = drop (length name) form
--- | otherwise= search name $ tail form
---
--- par s= takeWhile(/='\"') . dropWhile (/='\"') . tail . dropWhile (/='=') $ s
--- getPar= par $ search "name"
--- in getPar form
---
-
-waction :: (Functor m, MonadIO m,Generate a, FormInput view)
- => View view m a
- -> (a -> FlowM view m b)
- -> View view m b
-waction w f= do
- x <- liftIO generate
- MFlow.Forms.waction (return x) f
-
-userWidget :: ( MonadIO m, Functor m
- , FormInput view)
- => Maybe String
- -> View view m (Maybe (String,String), Maybe String)
- -> View view m String
-userWidget muser formuser= do
- user <- getCurrentUser
- if muser== Just user then return user
- else if isJust muser then do
- let user= fromJust muser
- login user >> return user
- else liftIO generate >>= \u -> login u >> return u
-
- where
- login uname= do
- st <- get
- let t = mfToken st
- t'= t{tuser= uname}
- put st{mfToken= t'}
- return ()
-
-getUserSimple :: ( MonadIO m, FormInput view, Typeable view
- , Functor m)
- => FlowM view m String
-getUserSimple= getUser Nothing userFormLine
-
-
-getUser :: ( FormInput view, Typeable view
- , Functor m,MonadIO m)
- => Maybe String
- -> View view m (Maybe (String,String), Maybe String)
- -> FlowM view m String
-getUser mu form= ask $ userWidget mu form
-
---wmodify
--- :: (Functor m, MonadIO m, FormInput v, Generate (Maybe a)) =>
--- View v m a1
--- -> ([v] -> Maybe a -> WState v m ([v], Maybe b))
--- -> View v m b
---wmodify formt act = do
--- x <- liftIO generate
--- formt `MFlow.Forms.wmodify` (\ f _-> return (f,x)) `MFlow.Forms.wmodify` act
-
-{-
-type Var= String
-data Test= Test{tflink:: [(Var,String)]
- ,selectOptions :: [(Var,[String])]
- ,tfinput :: [(Var, String)]
- ,tftextarea :: [(Var, String)]
- }
- deriving(Read,Show)
-
-type TestM = Test -> Test
-
-instance Monoid TestM where
- mempty= id
- mappend= (.)
-
-instance FormInput TestM where
- ftag = const id
- inred = const id
- fromStr = const id
- flink var _= let(n,v)=break (=='=') var in \t ->t{tflink= (n,tail v):tflink t}
- finput n _ v _ _ = \t -> t{tfinput = (n,v):tfinput t}
- ftextarea n v= \t -> t{tftextarea = (n,v):tftextarea t}
- fselect n _= \t -> t{selectOptions=(n,[]):selectOptions t}
- foption o _ _= \t ->
- let (n,opts)= head $ selectOptions t
- in t{selectOptions=(n,o:opts):tail (selectOptions t)}
- formAction _ _= id
- addAttributes _ _= id
-
-generateGenerate Test{..}= do
- b <- generate
- case b of
- True -> genLink
- False -> genForm
-
- where
- genForm= do
- -- one on every generate is incomplete
- n <- randomRIO(0,10) :: IO Int
- case n of
- 0 -> do
- genInput
-
- _ -> do
- r1 <- genInput
- r2 <- genSelect
- r3 <- genTextArea
- return $ r1++r2++r3
- genLink= do
- let n = length tflink
- if n == 0 then genForm
- else do
- r <- randomRIO(0,n )
- return [tflink !! r]
-
- genSelect=do
- let n = length selectOptions
- if n== 0
- then return []
- else mapM gen selectOptions
- where
- gen(s,os)= do
- let m = length os
- j <- randomRIO(0,m)
- return (s, os !! j)
-
- genInput= do
- let n = length tftextarea
- if n==0
- then return []
- else mapM gen tfinput
- where gen(n,_)= do
- str <- generate
- return $ (n,str)
-
- genTextArea= do
- let n = length tfinput
- if n==0
- then return []
- else mapM gen tftextarea
- where
- gen(n,_)= do
- str <- generate
- return $ (n,str)
-
-pwf= "pwf"
-ind= "ind"
-instance Processable Params where
- pwfname = fromMaybe noScript . lookup pwf
- puser= fromMaybe anonymous . lookup cookieuser
- pind = fromMaybe "0" . lookup ind
- getParams = id
-
-
-
-runTest nusers = do
- wfs <- getMessageFlows
- replicateM nusers $ gen wfs
- where
- gen wfs = do
- u <- generate
- mapM (genTraffic u) $ M.toList wfs
-
- genTraffic u (n,_)= forkIO $ iterategenerates [(pwf,n),(cookieuser,u)] []
-
- iterategenerates ident msg= iterate [] msg
- where
- iterate cs msg= do
- (HttpData ps cooks test,_) <- msgScheduler $ ident ++ cs++ msg
- let cs'= cs++ map (\(a,b,c,d)-> (a,b)) cooks
- resp <- generateGenerate . read $ B.unpack test
- iterate cs' resp
-
- -}
+
+ let t = Token x y z [] [] undefined undefined undefined
+ WF.start name f t
+
+testNumber= unsafePerformIO $ newIORef 0
+
+getTestNumber :: MonadIO m => m Int
+getTestNumber= liftIO $ readIORef testNumber
+
+-- | inject substitutes an expression by other. It may be used to override
+-- ask interaction with the user. It should bee used infix for greater readability:
+--
+-- > ask something `inject` const someother
+--
+-- The parameter passed is the test number
+-- if the flow has not been executed by runTest, inject return the original
+inject :: MonadIO m => m b -> (Int -> b) -> m b
+inject exp v= do
+ n <- getTestNumber
+ if n== 0 then exp else exp `seq` return $ v n
+
+-- | a simulated ask that generate simulated user input of the type expected.
+--
+-- It forces the web page rendering, since it is monadic and can contain
+-- side effects and load effects to be tested.
+--
+-- it is a substitute of 'ask' from "MFlow.Forms" for testing purposes.
+
+-- execute 'runText' to initiate threads under different load conditions.
+ask :: (Generate a, MonadIO m, Functor m, FormInput v,Typeable v) => View v m a -> FlowM v m a
+ask w = do
+ FormElm forms mx <- FlowM . lift $ runView w
+ r <- liftIO generate
+ let n= B.length $ toByteString forms
+ breturn $ n `seq` mx `seq` r
+-- let u= undefined
+-- liftIO $ runStateT (runView mf) s
+-- bool <- liftIO generate
+-- case bool of
+-- False -> fail ""
+-- True -> do
+-- b <- liftIO generate
+-- r <- liftIO generate
+-- case (b,r) of
+-- (True,x) -> breturn x
+-- _ -> ask w
+
+
+-- | instead of generating a result like `ask`, the result is given as the first parameter
+-- so it does not need a Generate instance.
+--
+-- It forces the web page rendering, since it is monadic so it can contain
+-- side effects and load effects to be tested.
+askt :: (MonadIO m, FormInput v) => (Int -> a) -> View v m a -> FlowM v m a
+askt v w = do
+ FormElm forms mx <- FlowM . lift $ runView w
+ n <- getTestNumber
+ let l= B.length $ toByteString forms
+ breturn $ l `seq` mx `seq` v n
+
+--mvtestopts :: MVar (M.Map String (Int,Dynamic))
+--mvtestopts = unsafePerformIO $ newMVar M.empty
+
+--asktn :: (Typeable a,MonadIO m) => [a] -> View v m a -> FlowM v m a
+--asktn xs w= do
+-- v <- liftIO $ do
+-- let k = addrStr xs
+-- opts <- takeMVar mvtestopts
+-- let r = M.lookup k opts
+-- case r of
+-- Nothing -> do
+-- putMVar mvtestopts $ M.singleton k (0,toDyn xs)
+-- return $ head xs
+-- Just (i,d) -> do
+-- putMVar mvtestopts $ M.insert k (i+1,d) opts
+-- return $ (fromMaybe (error err1) $ fromDynamic d) !! i
+--
+-- askt v w
+--
+-- where
+-- err1= "MFlow.Forms.Test: asktn: fromDynamic error"
+
+
+-- | verify a property. if not true, throw the error message.
+--
+-- It is intended to be used in a infix notation, on the right of the code,
+-- in order to separate the code assertions from the application code and make clearly
+-- visible them as a form of documentation.
+-- separated from it:
+--
+-- > liftIO $ print (x :: Int) `verify` (return $ x > 10, "x < = 10")
+--
+-- the expression is monadic to allow for complex verifications that may involve IO actions
+verifyM :: Monad m => m b -> (m Bool, String) -> m b
+verifyM f (mprop, msg)= do
+ prop <- mprop
+ case prop of
+ True -> f
+ False -> error msg
+
+-- | a pure version of verifyM
+verify :: a -> (Bool, String) -> a
+verify f (prop, msg)= do
+ case prop of
+ True -> f
+ False -> error msg
+
+
+--
+--match form=do
+-- marches <- readIORef matches
+-- return $ head map (m s) matches
+-- where
+-- m s (ms,ps) = case and $ map (flip isInfixOf $ s) ms of
+-- True -> Just ps
+-- False -> Nothing
+--
+--composeParams (Gen ps) form= zip (getParams form) ps
+-- where
+-- getParams form=
+-- let search name form
+-- | null form = mempty
+-- | isPrefix name form = drop (length name) form
+-- | otherwise= search name $ tail form
+--
+-- par s= takeWhile(/='\"') . dropWhile (/='\"') . tail . dropWhile (/='=') $ s
+-- getPar= par $ search "name"
+-- in getPar form
+--
+
+waction :: (Functor m, MonadIO m,Generate a, FormInput view)
+ => View view m a
+ -> (a -> FlowM view m b)
+ -> View view m b
+waction w f= do
+ x <- liftIO generate
+ MFlow.Forms.waction (return x) f
+
+userWidget :: ( MonadIO m, Functor m
+ , FormInput view)
+ => Maybe String
+ -> View view m (Maybe (String,String), Maybe String)
+ -> View view m String
+userWidget muser formuser= do
+ user <- getCurrentUser
+ if muser== Just user then return user
+ else if isJust muser then do
+ let user= fromJust muser
+ login user >> return user
+ else liftIO generate >>= \u -> login u >> return u
+
+ where
+ login uname= do
+ st <- get
+ let t = mfToken st
+ t'= t{tuser= uname}
+ put st{mfToken= t'}
+ return ()
+
+getUserSimple :: ( MonadIO m, FormInput view, Typeable view
+ , Functor m)
+ => FlowM view m String
+getUserSimple= getUser Nothing userFormLine
+
+
+getUser :: ( FormInput view, Typeable view
+ , Functor m,MonadIO m)
+ => Maybe String
+ -> View view m (Maybe (String,String), Maybe String)
+ -> FlowM view m String
+getUser mu form= ask $ userWidget mu form
+
+--wmodify
+-- :: (Functor m, MonadIO m, FormInput v, Generate (Maybe a)) =>
+-- View v m a1
+-- -> ([v] -> Maybe a -> WState v m ([v], Maybe b))
+-- -> View v m b
+--wmodify formt act = do
+-- x <- liftIO generate
+-- formt `MFlow.Forms.wmodify` (\ f _-> return (f,x)) `MFlow.Forms.wmodify` act
+
+{-
+type Var= String
+data Test= Test{tflink:: [(Var,String)]
+ ,selectOptions :: [(Var,[String])]
+ ,tfinput :: [(Var, String)]
+ ,tftextarea :: [(Var, String)]
+ }
+ deriving(Read,Show)
+
+type TestM = Test -> Test
+
+instance Monoid TestM where
+ mempty= id
+ mappend= (.)
+
+instance FormInput TestM where
+ ftag = const id
+ inred = const id
+ fromStr = const id
+ flink var _= let(n,v)=break (=='=') var in \t ->t{tflink= (n,tail v):tflink t}
+ finput n _ v _ _ = \t -> t{tfinput = (n,v):tfinput t}
+ ftextarea n v= \t -> t{tftextarea = (n,v):tftextarea t}
+ fselect n _= \t -> t{selectOptions=(n,[]):selectOptions t}
+ foption o _ _= \t ->
+ let (n,opts)= head $ selectOptions t
+ in t{selectOptions=(n,o:opts):tail (selectOptions t)}
+ formAction _ _= id
+ addAttributes _ _= id
+
+generateGenerate Test{..}= do
+ b <- generate
+ case b of
+ True -> genLink
+ False -> genForm
+
+ where
+ genForm= do
+ -- one on every generate is incomplete
+ n <- randomRIO(0,10) :: IO Int
+ case n of
+ 0 -> do
+ genInput
+
+ _ -> do
+ r1 <- genInput
+ r2 <- genSelect
+ r3 <- genTextArea
+ return $ r1++r2++r3
+ genLink= do
+ let n = length tflink
+ if n == 0 then genForm
+ else do
+ r <- randomRIO(0,n )
+ return [tflink !! r]
+
+ genSelect=do
+ let n = length selectOptions
+ if n== 0
+ then return []
+ else mapM gen selectOptions
+ where
+ gen(s,os)= do
+ let m = length os
+ j <- randomRIO(0,m)
+ return (s, os !! j)
+
+ genInput= do
+ let n = length tftextarea
+ if n==0
+ then return []
+ else mapM gen tfinput
+ where gen(n,_)= do
+ str <- generate
+ return $ (n,str)
+
+ genTextArea= do
+ let n = length tfinput
+ if n==0
+ then return []
+ else mapM gen tftextarea
+ where
+ gen(n,_)= do
+ str <- generate
+ return $ (n,str)
+
+pwf= "pwf"
+ind= "ind"
+instance Processable Params where
+ pwfname = fromMaybe noScript . lookup pwf
+ puser= fromMaybe anonymous . lookup cookieuser
+ pind = fromMaybe "0" . lookup ind
+ getParams = id
+
+
+
+runTest nusers = do
+ wfs <- getMessageFlows
+ replicateM nusers $ gen wfs
+ where
+ gen wfs = do
+ u <- generate
+ mapM (genTraffic u) $ M.toList wfs
+
+ genTraffic u (n,_)= forkIO $ iterategenerates [(pwf,n),(cookieuser,u)] []
+
+ iterategenerates ident msg= iterate [] msg
+ where
+ iterate cs msg= do
+ (HttpData ps cooks test,_) <- msgScheduler $ ident ++ cs++ msg
+ let cs'= cs++ map (\(a,b,c,d)-> (a,b)) cooks
+ resp <- generateGenerate . read $ B.unpack test
+ iterate cs' resp
+
+ -}
diff -ru orig/src/MFlow/Forms/Widgets.hs new/src/MFlow/Forms/Widgets.hs
--- orig/src/MFlow/Forms/Widgets.hs 2014-06-10 05:51:26.977015856 +0300
+++ new/src/MFlow/Forms/Widgets.hs 2014-06-10 05:51:25.000000000 +0300
@@ -1,114 +1,114 @@
-
-{- |
-Some dynamic widgets, widgets that dynamically edit content in other widgets,
-widgets for templating, content management and multilanguage. And some primitives
-to create other active widgets.
--}
+
+{- |
+Some dynamic widgets, widgets that dynamically edit content in other widgets,
+widgets for templating, content management and multilanguage. And some primitives
+to create other active widgets.
+-}
-- {-# OPTIONS -F -pgmF cpphs #-}
-{-# OPTIONS -cpp -pgmPcpphs -optP--cpp #-}
-{-# LANGUAGE UndecidableInstances,ExistentialQuantification
- , FlexibleInstances, OverlappingInstances, FlexibleContexts
+{-# OPTIONS -cpp -pgmPcpphs -optP--cpp #-}
+{-# LANGUAGE UndecidableInstances,ExistentialQuantification
+ , FlexibleInstances, OverlappingInstances, FlexibleContexts
, OverloadedStrings, DeriveDataTypeable , ScopedTypeVariables
- , StandaloneDeriving #-}
-
-
-
-
-module MFlow.Forms.Widgets (
--- * Ajax refreshing of widgets
-autoRefresh, noAutoRefresh, appendUpdate, prependUpdate, push, UpdateMethod(..), lazy
-
--- * JQueryUi widgets
-,datePicker, getSpinner, wautocomplete, wdialog,
-
--- * User Management
-userFormOrName,maybeLogout, wlogin,
-
--- * Active widgets
-wEditList,wautocompleteList
-, wautocompleteEdit,
-
--- * Editing widgets
-delEdited, getEdited, setEdited, prependWidget,appendWidget,setWidget
-
--- * Content Management
-,tField, tFieldEd, htmlEdit, edTemplate, dField, template, witerate,tfieldKey
-
--- * Multilanguage
-,mFieldEd, mField
-
--- * utility
-,insertForm, readtField, writetField
-
-
-) where
-import MFlow
-import MFlow.Forms
-import MFlow.Forms.Internals
-import Data.Monoid
+ , StandaloneDeriving #-}
+
+
+
+
+module MFlow.Forms.Widgets (
+-- * Ajax refreshing of widgets
+autoRefresh, noAutoRefresh, appendUpdate, prependUpdate, push, UpdateMethod(..), lazy
+
+-- * JQueryUi widgets
+,datePicker, getSpinner, wautocomplete, wdialog,
+
+-- * User Management
+userFormOrName,maybeLogout, wlogin,
+
+-- * Active widgets
+wEditList,wautocompleteList
+, wautocompleteEdit,
+
+-- * Editing widgets
+delEdited, getEdited, setEdited, prependWidget,appendWidget,setWidget
+
+-- * Content Management
+,tField, tFieldEd, htmlEdit, edTemplate, dField, template, witerate,tfieldKey
+
+-- * Multilanguage
+,mFieldEd, mField
+
+-- * utility
+,insertForm, readtField, writetField
+
+
+) where
+import MFlow
+import MFlow.Forms
+import MFlow.Forms.Internals
+import Data.Monoid
import Data.ByteString.Lazy.UTF8 as B hiding (length,span)
-import Data.ByteString.Lazy.Char8 (unpack)
-import Control.Monad.Trans
-import Data.Typeable
-import Data.List
-import System.IO.Unsafe
-
-import Control.Monad.State
-import Data.TCache
-import Data.TCache.Defs
-import Data.TCache.Memoization
-import Data.RefSerialize hiding ((<|>))
-import qualified Data.Map as M
-import Data.IORef
-import MFlow.Cookies
-import Data.Maybe
-import Data.Char
-import Control.Monad.Identity
-import Control.Workflow(killWF)
-import Unsafe.Coerce
-import Control.Exception
+import Data.ByteString.Lazy.Char8 (unpack)
+import Control.Monad.Trans
+import Data.Typeable
+import Data.List
+import System.IO.Unsafe
+
+import Control.Monad.State
+import Data.TCache
+import Data.TCache.Defs
+import Data.TCache.Memoization
+import Data.RefSerialize hiding ((<|>))
+import qualified Data.Map as M
+import Data.IORef
+import MFlow.Cookies
+import Data.Maybe
+import Data.Char
+import Control.Monad.Identity
+import Control.Workflow(killWF)
+import Unsafe.Coerce
+import Control.Exception
import MFlow.Forms.Cache
-
-
-
---jqueryScript= "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"
---jqueryScript1="//code.jquery.com/jquery-1.9.1.js"
---
---jqueryCSS1= "//code.jquery.com/ui/1.9.1/themes/base/jquery-ui.css"
---jqueryCSS= "//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css"
---
---jqueryUI1= "//code.jquery.com/ui/1.9.1/jquery-ui.js"
---jqueryUI= "//code.jquery.com/ui/1.10.3/jquery-ui.js"
-
-jqueryScript= getConfig "cjqueryScript" "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"
-jqueryCSS= getConfig "cjqueryCSS" "//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css"
-jqueryUI= getConfig "cjqueryUI" "//code.jquery.com/ui/1.10.3/jquery-ui.js"
-nicEditUrl= getConfig "cnicEditUrl" "//js.nicedit.com/nicEdit-latest.js"
-------- User Management ------
-
--- | Present a user form if not logged in. Otherwise, the user name and a logout link is presented.
--- The paremeters and the behaviour are the same as 'userWidget'.
--- Only the display is different
-userFormOrName mode wid= userWidget mode wid `wmodify` f <** maybeLogout
- where
- f _ justu@(Just u) = return ([fromStr u], justu) -- !> "input"
- f felem Nothing = do
- us <- getCurrentUser -- getEnv cookieuser
- if us == anonymous
- then return (felem, Nothing)
- else return([fromStr us], Just us)
-
--- | Display a logout link if the user is logged. Nothing otherwise
-maybeLogout :: (MonadIO m,Functor m,FormInput v) => View v m ()
-maybeLogout= do
- us <- getCurrentUser
- if us/= anonymous
- then do
- cmd <- ajax $ const $ return "window.location=='/'" --refresh
- fromStr " " ++> ((wlink () (fromStr "logout")) <![("onclick",cmd "''")]) `waction` const logout
+
+
+
+--jqueryScript= "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"
+--jqueryScript1="//code.jquery.com/jquery-1.9.1.js"
+--
+--jqueryCSS1= "//code.jquery.com/ui/1.9.1/themes/base/jquery-ui.css"
+--jqueryCSS= "//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css"
+--
+--jqueryUI1= "//code.jquery.com/ui/1.9.1/jquery-ui.js"
+--jqueryUI= "//code.jquery.com/ui/1.10.3/jquery-ui.js"
+
+jqueryScript= getConfig "cjqueryScript" "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"
+jqueryCSS= getConfig "cjqueryCSS" "//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css"
+jqueryUI= getConfig "cjqueryUI" "//code.jquery.com/ui/1.10.3/jquery-ui.js"
+nicEditUrl= getConfig "cnicEditUrl" "//js.nicedit.com/nicEdit-latest.js"
+------- User Management ------
+
+-- | Present a user form if not logged in. Otherwise, the user name and a logout link is presented.
+-- The paremeters and the behaviour are the same as 'userWidget'.
+-- Only the display is different
+userFormOrName mode wid= userWidget mode wid `wmodify` f <** maybeLogout
+ where
+ f _ justu@(Just u) = return ([fromStr u], justu) -- !> "input"
+ f felem Nothing = do
+ us <- getCurrentUser -- getEnv cookieuser
+ if us == anonymous
+ then return (felem, Nothing)
+ else return([fromStr us], Just us)
+
+-- | Display a logout link if the user is logged. Nothing otherwise
+maybeLogout :: (MonadIO m,Functor m,FormInput v) => View v m ()
+maybeLogout= do
+ us <- getCurrentUser
+ if us/= anonymous
+ then do
+ cmd <- ajax $ const $ return "window.location=='/'" --refresh
+ fromStr " " ++> ((wlink () (fromStr "logout")) <![("onclick",cmd "''")]) `waction` const logout
else noWidget
-
+
data Medit view m a = Medit (M.Map B.ByteString [(String,View view m a)])
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
@@ -129,46 +129,46 @@
ta :: Medit v m a -> a
ta= undefined
-#endif
-
--- | If not logged, it present a page flow which askm for the user name, then the password if not logged
---
--- If logged, it present the user name and a link to logout
---
--- normally to be used with autoRefresh and pageFlow when used with other widgets.
-wlogin :: (MonadIO m,Functor m,FormInput v) => View v m ()
-wlogin= do
- username <- getCurrentUser
- if username /= anonymous
+#endif
+
+-- | If not logged, it present a page flow which askm for the user name, then the password if not logged
+--
+-- If logged, it present the user name and a link to logout
+--
+-- normally to be used with autoRefresh and pageFlow when used with other widgets.
+wlogin :: (MonadIO m,Functor m,FormInput v) => View v m ()
+wlogin= wform $ do
+ username <- getCurrentUser
+ if username /= anonymous
then do
private; noCache;noStore
- return username
- else do
+ return username
+ else do
name <- getString Nothing <! hint "login name"
<! size (9 :: Int)
- <++ ftag "br" mempty
+ <++ ftag "br" mempty
pass <- getPassword <! hint "password"
- <! size 9
- <++ ftag "br" mempty
- <** submitButton "login"
- val <- userValidate (name,pass)
- case val of
- Just msg -> notValid msg
- Nothing -> login name >> (return name)
-
- `wcallback` (\name -> ftag "b" (fromStr $ "logged as " ++ name++ " ")
- ++> pageFlow "logout" (submitButton "logout")) -- wlink ("logout" :: String) (ftag "b" $ fromStr " logout"))
- `wcallback` const (logout >> wlogin)
-
-focus = [("onload","this.focus()")]
-hint s= [("placeholder",s)]
-size n= [("size",show n)]
-
-getEdited1 id= do
- Medit stored <- getSessionData `onNothing` return (Medit M.empty)
- return $ fromMaybe [] $ M.lookup id stored
-
--- | Return the list of edited widgets (added by the active widgets) for a given identifier
+ <! size 9
+ <++ ftag "br" mempty
+ <** submitButton "login"
+ val <- userValidate (name,pass)
+ case val of
+ Just msg -> notValid msg
+ Nothing -> login name >> (return name)
+
+ `wcallback` (\name -> ftag "b" (fromStr $ "logged as " ++ name++ " ")
+ ++> pageFlow "logout" (submitButton "logout")) -- wlink ("logout" :: String) (ftag "b" $ fromStr " logout"))
+ `wcallback` const (logout >> wlogin)
+
+focus = [("onload","this.focus()")]
+hint s= [("placeholder",s)]
+size n= [("size",show n)]
+
+getEdited1 id= do
+ Medit stored <- getSessionData `onNothing` return (Medit M.empty)
+ return $ fromMaybe [] $ M.lookup id stored
+
+-- | Return the list of edited widgets (added by the active widgets) for a given identifier
getEdited
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
@@ -181,15 +181,15 @@
#endif
- B.ByteString -> m [View v m1 a]
+ B.ByteString -> m [View v m1 a]
+
+getEdited id= do
+ r <- getEdited1 id
+ let (_,ws)= unzip r
+ return ws
-getEdited id= do
- r <- getEdited1 id
- let (_,ws)= unzip r
- return ws
-
--- | Deletes the list of edited widgets for a certain identifier and with the type of the witness widget parameter
-delEdited
+-- | Deletes the list of edited widgets for a certain identifier and with the type of the witness widget parameter
+delEdited
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
:: (Typeable v, Typeable a, MonadIO m, Typeable m1,
#else
@@ -197,312 +197,312 @@
#endif
MonadState (MFlowState view) m)
=> B.ByteString -- ^ identifier
- -> [View v m1 a] -> m () -- ^ withess
-delEdited id witness=do
- Medit stored <- getSessionData `onNothing` return (Medit (M.empty))
- let (ks, ws)= unzip $ fromMaybe [] $ M.lookup id stored
-
- return $ ws `asTypeOf` witness
- liftIO $ mapM flushCached ks
- let stored'= M.delete id stored
- setSessionData . Medit $ stored'
-
-
-
--- setEdited id ([] `asTypeOf` (zip (repeat "") witness))
-
-setEdited id ws= do
- Medit stored <- getSessionData `onNothing` return (Medit (M.empty))
- let stored'= M.insert id ws stored
- setSessionData . Medit $ stored'
-
-
-addEdited id w= do
- ws <- getEdited1 id
- setEdited id (w:ws)
-
+ -> [View v m1 a] -> m () -- ^ withess
+delEdited id witness=do
+ Medit stored <- getSessionData `onNothing` return (Medit (M.empty))
+ let (ks, ws)= unzip $ fromMaybe [] $ M.lookup id stored
+
+ return $ ws `asTypeOf` witness
+ liftIO $ mapM flushCached ks
+ let stored'= M.delete id stored
+ setSessionData . Medit $ stored'
+
+
+
+-- setEdited id ([] `asTypeOf` (zip (repeat "") witness))
+
+setEdited id ws= do
+ Medit stored <- getSessionData `onNothing` return (Medit (M.empty))
+ let stored'= M.insert id ws stored
+ setSessionData . Medit $ stored'
+
+
+addEdited id w= do
+ ws <- getEdited1 id
+ setEdited id (w:ws)
+
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
modifyWidget :: (MonadIO m,Executable m,Typeable a,FormInput v, Typeable Identity, Typeable m)
-#else
-modifyWidget :: (MonadIO m,Executable m,Typeable a,FormInput v)
+#else
+modifyWidget :: (MonadIO m,Executable m,Typeable a,FormInput v)
#endif
- => B.ByteString -> B.ByteString -> View v Identity a -> View v m B.ByteString
-modifyWidget selector modifier w = View $ do
- ws <- getEdited selector
- let n = length (ws `asTypeOf` [w])
- let key= "widget"++ show selector ++ show n ++ show (typeOf $ typ w)
- let cw = wcached key 0 w
- addEdited selector (key,cw)
- FormElm form _ <- runView cw
- let elem= toByteString form
- return . FormElm mempty . Just $ selector <> "." <> modifier <>"('" <> elem <> "');"
- where
- typ :: View v Identity a -> a
- typ = undefined
-
--- | Return the javascript to be executed on the browser to prepend a widget to the location
--- identified by the selector (the bytestring parameter), The selector must have the form of a jquery expression
--- . It stores the added widgets in the edited list, that is accessed with 'getEdited'
---
--- The resulting string can be executed in the browser. 'ajax' will return the code to
--- execute the complete ajax roundtrip. This code returned by ajax must be in an eventhabdler.
---
--- This example will insert a widget in the div when the element with identifier
--- /clickelem/ is clicked. when the form is sbmitted, the widget values are returned
--- and the list of edited widgets are deleted.
---
--- > id1<- genNewId
--- > let sel= "$('#" <> fromString id1 <> "')"
--- > callAjax <- ajax . const $ prependWidget sel wn
--- > let installevents= "$(document).ready(function(){\
--- > \$('#clickelem').click(function(){"++callAjax "''"++"});})"
--- >
--- > requires [JScriptFile jqueryScript [installevents] ]
--- > ws <- getEdited sel
--- > r <- (div <<< manyOf ws) <! [("id",id1)]
--- > delEdited sel ws'
--- > return r
-
+ => B.ByteString -> B.ByteString -> View v Identity a -> View v m B.ByteString
+modifyWidget selector modifier w = View $ do
+ ws <- getEdited selector
+ let n = length (ws `asTypeOf` [w])
+ let key= "widget"++ show selector ++ show n ++ show (typeOf $ typ w)
+ let cw = wcached key 0 w
+ addEdited selector (key,cw)
+ FormElm form _ <- runView cw
+ let elem= toByteString form
+ return . FormElm mempty . Just $ selector <> "." <> modifier <>"('" <> elem <> "');"
+ where
+ typ :: View v Identity a -> a
+ typ = undefined
+
+-- | Return the javascript to be executed on the browser to prepend a widget to the location
+-- identified by the selector (the bytestring parameter), The selector must have the form of a jquery expression
+-- . It stores the added widgets in the edited list, that is accessed with 'getEdited'
+--
+-- The resulting string can be executed in the browser. 'ajax' will return the code to
+-- execute the complete ajax roundtrip. This code returned by ajax must be in an eventhabdler.
+--
+-- This example will insert a widget in the div when the element with identifier
+-- /clickelem/ is clicked. when the form is sbmitted, the widget values are returned
+-- and the list of edited widgets are deleted.
+--
+-- > id1<- genNewId
+-- > let sel= "$('#" <> fromString id1 <> "')"
+-- > callAjax <- ajax . const $ prependWidget sel wn
+-- > let installevents= "$(document).ready(function(){\
+-- > \$('#clickelem').click(function(){"++callAjax "''"++"});})"
+-- >
+-- > requires [JScriptFile jqueryScript [installevents] ]
+-- > ws <- getEdited sel
+-- > r <- (div <<< manyOf ws) <! [("id",id1)]
+-- > delEdited sel ws'
+-- > return r
+
prependWidget
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
:: (Typeable a, MonadIO m, Executable m, FormInput v, Typeable Identity, Typeable m)
-#else
+#else
:: (Typeable a, MonadIO m, Executable m, FormInput v)
-#endif
- => B.ByteString -- ^ jquery selector
- -> View v Identity a -- ^ widget to prepend
- -> View v m B.ByteString -- ^ string returned with the jquery string to be executed in the browser
-prependWidget sel w= modifyWidget sel "prepend" w
-
--- | Like 'prependWidget' but append the widget instead of prepend.
-appendWidget
+#endif
+ => B.ByteString -- ^ jquery selector
+ -> View v Identity a -- ^ widget to prepend
+ -> View v m B.ByteString -- ^ string returned with the jquery string to be executed in the browser
+prependWidget sel w= modifyWidget sel "prepend" w
+
+-- | Like 'prependWidget' but append the widget instead of prepend.
+appendWidget
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
:: (Typeable a, MonadIO m, Executable m, FormInput v, Typeable Identity, Typeable m) =>
#else
:: (Typeable a, MonadIO m, Executable m, FormInput v) =>
#endif
- B.ByteString -> View v Identity a -> View v m B.ByteString
-appendWidget sel w= modifyWidget sel "append" w
-
--- | L ike 'prependWidget' but set the entire content of the selector instead of prepending an element
-setWidget
+ B.ByteString -> View v Identity a -> View v m B.ByteString
+appendWidget sel w= modifyWidget sel "append" w
+
+-- | L ike 'prependWidget' but set the entire content of the selector instead of prepending an element
+setWidget
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
:: (Typeable a, MonadIO m, Executable m, FormInput v, Typeable m, Typeable Identity) =>
#else
:: (Typeable a, MonadIO m, Executable m, FormInput v) =>
-#endif
- B.ByteString -> View v Identity a -> View v m B.ByteString
-setWidget sel w= modifyWidget sel "html" w
-
-
--- | Inside a tag, it add and delete widgets of the same type. When the form is submitted
--- or a wlink is pressed, this widget return the list of validated widgets.
--- the event for adding a new widget is attached , as a click event to the element of the page with the identifier /wEditListAdd/
--- that the user will choose.
---
--- This example add or delete editable text boxes, with two initial boxes with
--- /hi/, /how are you/ as values. Tt uses blaze-html:
---
--- > r <- ask $ addLink
--- > ++> br
--- > ++> (El.div `wEditList` getString1 $ ["hi", "how are you"]) "addid"
--- > <++ br
--- > <** submitButton "send"
--- >
--- > ask $ p << (show r ++ " returned")
--- > ++> wlink () (p << text " back to menu")
--- > mainmenu
--- > where
--- > addLink = a ! At.id "addid"
--- > ! href "#"
--- > $ text "add"
--- > delBox = input ! type_ "checkbox"
--- > ! checked ""
--- > ! onclick "this.parentNode.parentNode.removeChild(this.parentNode)"
--- > getString1 mx= El.div <<< delBox ++> getString mx <++ br
-
-wEditList :: (Typeable a,Read a
+#endif
+ B.ByteString -> View v Identity a -> View v m B.ByteString
+setWidget sel w= modifyWidget sel "html" w
+
+
+-- | Inside a tag, it add and delete widgets of the same type. When the form is submitted
+-- or a wlink is pressed, this widget return the list of validated widgets.
+-- the event for adding a new widget is attached , as a click event to the element of the page with the identifier /wEditListAdd/
+-- that the user will choose.
+--
+-- This example add or delete editable text boxes, with two initial boxes with
+-- /hi/, /how are you/ as values. Tt uses blaze-html:
+--
+-- > r <- ask $ addLink
+-- > ++> br
+-- > ++> (El.div `wEditList` getString1 $ ["hi", "how are you"]) "addid"
+-- > <++ br
+-- > <** submitButton "send"
+-- >
+-- > ask $ p << (show r ++ " returned")
+-- > ++> wlink () (p << text " back to menu")
+-- > mainmenu
+-- > where
+-- > addLink = a ! At.id "addid"
+-- > ! href "#"
+-- > $ text "add"
+-- > delBox = input ! type_ "checkbox"
+-- > ! checked ""
+-- > ! onclick "this.parentNode.parentNode.removeChild(this.parentNode)"
+-- > getString1 mx= El.div <<< delBox ++> getString mx <++ br
+
+wEditList :: (Typeable a,Read a
,FormInput view
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
,Functor m,MonadIO m, Executable m, Typeable m, Typeable Identity)
-#else
+#else
,Functor m,MonadIO m, Executable m)
-#endif
- => (view ->view) -- ^ The holder tag
- -> (Maybe String -> View view Identity a) -- ^ the contained widget, initialized by a string
- -> [String] -- ^ The initial list of values.
- -> String -- ^ The id of the button or link that will create a new list element when clicked
- -> View view m [a]
-wEditList holderview w xs addId = do
- let ws= map (w . Just) xs
- wn= w Nothing
- id1<- genNewId
- let sel= "$('#" <> fromString id1 <> "')"
- callAjax <- ajax . const $ prependWidget sel wn
- let installevents= "$(document).ready(function(){$('#"++addId++"').click(function(){"++callAjax "''"++"});})"
-
- requires [JScriptFile jqueryScript [installevents] ]
-
- ws' <- getEdited sel
-
- r <- (holderview <<< (allOf $ ws' ++ map changeMonad ws)) <! [("id",id1)]
- delEdited sel ws'
- return r
-
-
-
-
--- | Present the JQuery autocompletion list, from a procedure defined by the programmer, to a text box.
-wautocomplete
- :: (Show a, MonadIO m, FormInput v)
- => Maybe String -- ^ Initial value
- -> (String -> IO a) -- ^ Autocompletion procedure: will receive a prefix and return a list of strings
- -> View v m String
-wautocomplete mv autocomplete = do
- text1 <- genNewId
- ajaxc <- ajax $ \u -> do
- r <- liftIO $ autocomplete u
- return $ jaddtoautocomp text1 r
-
-
- requires [JScriptFile jqueryScript [] -- [events]
- ,CSSFile jqueryCSS
- ,JScriptFile jqueryUI []]
-
-
- getString mv <! [("type", "text")
- ,("id", text1)
- ,("oninput", ajaxc $ "$('#"++text1++"').attr('value')" )
- ,("autocomplete", "off")]
-
-
- where
- jaddtoautocomp text1 us= "$('#"<>fromString text1<>"').autocomplete({ source: " <> fromString( show us) <> " });"
-
-
--- | Produces a text box. It gives a autocompletion list to the textbox. When return
--- is pressed in the textbox, the box content is used to create a widget of a kind defined
--- by the user, which will be situated above of the textbox. When submitted, the result is the content
--- of the created widgets (the validated ones).
---
--- 'wautocompleteList' is an specialization of this widget, where
--- the widget parameter is fixed, with a checkbox that delete the eleement when unselected
--- . This fixed widget is as such (using generic 'FormElem' class tags):
---
--- > ftag "div" <<< ftag "input" mempty
--- > `attrs` [("type","checkbox")
--- > ,("checked","")
--- > ,("onclick","this.parentNode.parentNode.removeChild(this.parentNode)")]
--- > ++> ftag "span" (fromStr $ fromJust x )
--- > ++> whidden( fromJust x)
-wautocompleteEdit
+#endif
+ => (view ->view) -- ^ The holder tag
+ -> (Maybe String -> View view Identity a) -- ^ the contained widget, initialized by a string
+ -> [String] -- ^ The initial list of values.
+ -> String -- ^ The id of the button or link that will create a new list element when clicked
+ -> View view m [a]
+wEditList holderview w xs addId = do
+ let ws= map (w . Just) xs
+ wn= w Nothing
+ id1<- genNewId
+ let sel= "$('#" <> fromString id1 <> "')"
+ callAjax <- ajax . const $ prependWidget sel wn
+ let installevents= "$(document).ready(function(){$('#"++addId++"').click(function(){"++callAjax "''"++"});})"
+
+ requires [JScriptFile jqueryScript [installevents] ]
+
+ ws' <- getEdited sel
+
+ r <- (holderview <<< (allOf $ ws' ++ map changeMonad ws)) <! [("id",id1)]
+ delEdited sel ws'
+ return r
+
+
+
+
+-- | Present the JQuery autocompletion list, from a procedure defined by the programmer, to a text box.
+wautocomplete
+ :: (Show a, MonadIO m, FormInput v)
+ => Maybe String -- ^ Initial value
+ -> (String -> IO a) -- ^ Autocompletion procedure: will receive a prefix and return a list of strings
+ -> View v m String
+wautocomplete mv autocomplete = do
+ text1 <- genNewId
+ ajaxc <- ajax $ \u -> do
+ r <- liftIO $ autocomplete u
+ return $ jaddtoautocomp text1 r
+
+
+ requires [JScriptFile jqueryScript [] -- [events]
+ ,CSSFile jqueryCSS
+ ,JScriptFile jqueryUI []]
+
+
+ getString mv <! [("type", "text")
+ ,("id", text1)
+ ,("oninput", ajaxc $ "$('#"++text1++"').attr('value')" )
+ ,("autocomplete", "off")]
+
+
+ where
+ jaddtoautocomp text1 us= "$('#"<>fromString text1<>"').autocomplete({ source: " <> fromString( show us) <> " });"
+
+
+-- | Produces a text box. It gives a autocompletion list to the textbox. When return
+-- is pressed in the textbox, the box content is used to create a widget of a kind defined
+-- by the user, which will be situated above of the textbox. When submitted, the result is the content
+-- of the created widgets (the validated ones).
+--
+-- 'wautocompleteList' is an specialization of this widget, where
+-- the widget parameter is fixed, with a checkbox that delete the eleement when unselected
+-- . This fixed widget is as such (using generic 'FormElem' class tags):
+--
+-- > ftag "div" <<< ftag "input" mempty
+-- > `attrs` [("type","checkbox")
+-- > ,("checked","")
+-- > ,("onclick","this.parentNode.parentNode.removeChild(this.parentNode)")]
+-- > ++> ftag "span" (fromStr $ fromJust x )
+-- > ++> whidden( fromJust x)
+wautocompleteEdit
:: (Typeable a, MonadIO m,Functor m, Executable m
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
, FormInput v, Typeable m, Typeable Identity)
-#else
+#else
, FormInput v)
-#endif
- => String -- ^ the initial text of the box
- -> (String -> IO [String]) -- ^ the autocompletion procedure: receives a prefix, return a list of options.
- -> (Maybe String -> View v Identity a) -- ^ the widget to add, initialized with the string entered in the box
- -> [String] -- ^ initial set of values
- -> View v m [a] -- ^ resulting widget
-wautocompleteEdit phold autocomplete elem values= do
- id1 <- genNewId
- let textx= id1++"text"
- let sel= "$('#" <> fromString id1 <> "')"
- ajaxc <- ajax $ \(c:u) ->
- case c of
- 'f' -> prependWidget sel (elem $ Just u)
- _ -> do
- r <- liftIO $ autocomplete u
- return $ jaddtoautocomp textx r
-
-
- requires [JScriptFile jqueryScript [events textx ajaxc]
- ,CSSFile jqueryCSS
- ,JScriptFile jqueryUI []]
-
- ws' <- getEdited sel
-
- r<- (ftag "div" mempty `attrs` [("id", id1)]
- ++> allOf (ws' ++ (map (changeMonad . elem . Just) values)))
- <++ ftag "input" mempty
- `attrs` [("type", "text")
- ,("id", textx)
- ,("placeholder", phold)
- ,("oninput", ajaxc $ "'n'+$('#"++textx++"').val()" )
- ,("autocomplete", "off")]
- delEdited sel ws'
- return r
- where
- events textx ajaxc=
- "$(document).ready(function(){ \
- \$('#"++textx++"').keydown(function(){ \
- \if(event.keyCode == 13){ \
- \var v= $('#"++textx++"').val(); \
- \if(event.preventDefault) event.preventDefault();\
- \else if(event.returnValue) event.returnValue = false;" ++
- ajaxc "'f'+v"++";"++
- " $('#"++textx++"').val('');\
- \}\
- \});\
- \});"
-
- jaddtoautocomp textx us= "$('#"<>fromString textx<>"').autocomplete({ source: " <> fromString( show us) <> " });"
+#endif
+ => String -- ^ the initial text of the box
+ -> (String -> IO [String]) -- ^ the autocompletion procedure: receives a prefix, return a list of options.
+ -> (Maybe String -> View v Identity a) -- ^ the widget to add, initialized with the string entered in the box
+ -> [String] -- ^ initial set of values
+ -> View v m [a] -- ^ resulting widget
+wautocompleteEdit phold autocomplete elem values= do
+ id1 <- genNewId
+ let textx= id1++"text"
+ let sel= "$('#" <> fromString id1 <> "')"
+ ajaxc <- ajax $ \(c:u) ->
+ case c of
+ 'f' -> prependWidget sel (elem $ Just u)
+ _ -> do
+ r <- liftIO $ autocomplete u
+ return $ jaddtoautocomp textx r
+
+
+ requires [JScriptFile jqueryScript [events textx ajaxc]
+ ,CSSFile jqueryCSS
+ ,JScriptFile jqueryUI []]
+
+ ws' <- getEdited sel
+
+ r<- (ftag "div" mempty `attrs` [("id", id1)]
+ ++> allOf (ws' ++ (map (changeMonad . elem . Just) values)))
+ <++ ftag "input" mempty
+ `attrs` [("type", "text")
+ ,("id", textx)
+ ,("placeholder", phold)
+ ,("oninput", ajaxc $ "'n'+$('#"++textx++"').val()" )
+ ,("autocomplete", "off")]
+ delEdited sel ws'
+ return r
+ where
+ events textx ajaxc=
+ "$(document).ready(function(){ \
+ \$('#"++textx++"').keydown(function(){ \
+ \if(event.keyCode == 13){ \
+ \var v= $('#"++textx++"').val(); \
+ \if(event.preventDefault) event.preventDefault();\
+ \else if(event.returnValue) event.returnValue = false;" ++
+ ajaxc "'f'+v"++";"++
+ " $('#"++textx++"').val('');\
+ \}\
+ \});\
+ \});"
+
+ jaddtoautocomp textx us= "$('#"<>fromString textx<>"').autocomplete({ source: " <> fromString( show us) <> " });"
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
deriving instance Typeable Identity
#endif
-
--- | A specialization of 'wutocompleteEdit' which make appear each chosen option with
--- a checkbox that deletes the element when uncheched. The result, when submitted, is the list of selected elements.
+
+-- | A specialization of 'wutocompleteEdit' which make appear each chosen option with
+-- a checkbox that deletes the element when uncheched. The result, when submitted, is the list of selected elements.
wautocompleteList
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 707)
:: (Functor m, MonadIO m, Executable m, FormInput v, Typeable m, Typeable Identity) =>
-#else
+#else
:: (Functor m, MonadIO m, Executable m, FormInput v) =>
-#endif
- String -> (String -> IO [String]) -> [String] -> View v m [String]
-wautocompleteList phold serverproc values=
- wautocompleteEdit phold serverproc wrender1 values
- where
- wrender1 x= ftag "div" <<< ftag "input" mempty
- `attrs` [("type","checkbox")
- ,("checked","")
- ,("onclick","this.parentNode.parentNode.removeChild(this.parentNode)")]
- ++> ftag "span" (fromStr $ fromJust x )
- ++> whidden( fromJust x)
-
-------- Templating and localization ---------
-
-data TField = TField {tfieldKey :: Key, tfieldContent :: B.ByteString} deriving (Read, Show,Typeable)
-
-instance Indexable TField where
- key (TField k _)= k
- defPath _= "texts/"
-
-
-instance Serializable TField where
- serialize (TField k content) = content
- deserialKey k content= TField k content -- applyDeserializers [des1,des2] k bs
-
-
- setPersist = \_ -> Just filePersist
-
-
-
-writetField k s= atomically $ writeDBRef (getDBRef k) $ TField k $ toByteString s
-
-
-readtField text k= atomically $ do
- let ref = getDBRef k
- mr <- readDBRef ref
- case mr of
- Just (TField k v) -> if v /= mempty then return $ fromStrNoEncode $ toString v else return text
- Nothing -> return text
-
+#endif
+ String -> (String -> IO [String]) -> [String] -> View v m [String]
+wautocompleteList phold serverproc values=
+ wautocompleteEdit phold serverproc wrender1 values
+ where
+ wrender1 x= ftag "div" <<< ftag "input" mempty
+ `attrs` [("type","checkbox")
+ ,("checked","")
+ ,("onclick","this.parentNode.parentNode.removeChild(this.parentNode)")]
+ ++> ftag "span" (fromStr $ fromJust x )
+ ++> whidden( fromJust x)
+
+------- Templating and localization ---------
+
+data TField = TField {tfieldKey :: Key, tfieldContent :: B.ByteString} deriving (Read, Show,Typeable)
+
+instance Indexable TField where
+ key (TField k _)= k
+ defPath _= "texts/"
+
+
+instance Serializable TField where
+ serialize (TField k content) = content
+ deserialKey k content= TField k content -- applyDeserializers [des1,des2] k bs
+
+
+ setPersist = \_ -> Just filePersist
+
+
+
+writetField k s= atomically $ writeDBRef (getDBRef k) $ TField k $ toByteString s
+
+
+readtField text k= atomically $ do
+ let ref = getDBRef k
+ mr <- readDBRef ref
+ case mr of
+ Just (TField k v) -> if v /= mempty then return $ fromStrNoEncode $ toString v else return text
+ Nothing -> return text
+
-- | Creates a rich text editor aroun a text field or a text area widget.
-- This code:
--
@@ -512,221 +512,224 @@
-- > <** submitButton "enter"
--
-- Creates a rich text area with bold and italic buttons. The buttons are the ones alled
--- in the nicEdit editor.
-htmlEdit :: (Monad m, FormInput v) => [String] -> UserStr -> View v m a -> View v m a
-htmlEdit buttons jsuser w = do
- id <- genNewId
-
- let installHtmlField=
- "\nfunction installHtmlField(muser,cookieuser,name,buttons){\
- \if(muser== '' || document.cookie.search(cookieuser+'='+muser) != -1)\
- \bkLib.onDomLoaded(function() {\
- \var myNicEditor = new nicEditor({buttonList : buttons});\
- \myNicEditor.panelInstance(name);\
- \})};\n"
- install= "installHtmlField('"++jsuser++"','"++cookieuser++"','"++id++"',"++show buttons++");\n"
-
- requires [JScriptFile nicEditUrl [installHtmlField,install]]
- w <! [("id",id)]
-
-
-
-
--- | A widget that display the content of an html, But if the user has edition privileges,
--- it permits to edit it in place. So the editor could see the final appearance
--- of what he writes.
---
--- When the user click the save, the content is saved and
--- identified by the key. Then, from now on, all the users will see the saved
--- content instead of the code content.
---
--- The content is saved in a file by default (/texts/ in this versions), but there is
--- a configurable version (`tFieldGen`). The content of the element and the formatting
--- is cached in memory, so the display is, theoretically, very fast.
---
-
-tFieldEd
- :: (Functor m, MonadIO m, Executable m,
- FormInput v) =>
- UserStr -> Key -> v -> View v m ()
-tFieldEd muser k text= wfreeze k 0 $ do
- content <- liftIO $ readtField text k
- nam <- genNewId
- let ipanel= nam++"panel"
- name= nam++"-"++k
- install= "\ninstallEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n"
- getTexts :: (Token -> IO ())
- getTexts token = do
- let (k,s):_ = tenv token
- liftIO $ do
- writetField k $ (fromStrNoEncode s `asTypeOf` text)
- flushCached k
- sendFlush token $ HttpData [] [] ""
- return()
-
- requires [JScriptFile nicEditUrl [install]
- ,JScript ajaxSendText
- ,JScript installEditField
--- ,JScriptFile jqueryScript []
- ,ServerProc ("_texts", transient getTexts)]
+-- in the nicEdit editor.
+htmlEdit :: (Monad m, FormInput v) => [String] -> UserStr -> View v m a -> View v m a
+htmlEdit buttons jsuser w = do
+ id <- genNewId
+
+ let installHtmlField=
+ "\nfunction installHtmlField(muser,cookieuser,name,buttons){\
+ \if(muser== '' || document.cookie.search(cookieuser+'='+muser) != -1)\
+ \bkLib.onDomLoaded(function() {\
+ \var myNicEditor = new nicEditor({buttonList : buttons});\
+ \myNicEditor.panelInstance(name);\
+ \})};\n"
+ install= "installHtmlField('"++jsuser++"','"++cookieuser++"','"++id++"',"++show buttons++");\n"
+
+ requires [JScript installHtmlField ,JScriptFile nicEditUrl [install]]
+ w <! [("id",id)]
+
+
+
+
+-- | A widget that display the content of an html, But if the user has edition privileges,
+-- it permits to edit it in place. So the editor could see the final appearance
+-- of what he writes.
+--
+-- When the user click the save, the content is saved and
+-- identified by the key. Then, from now on, all the users will see the saved
+-- content instead of the code content.
+--
+-- The content is saved in a file by default (/texts/ in this versions), but there is
+-- a configurable version (`tFieldGen`). The content of the element and the formatting
+-- is cached in memory, so the display is, theoretically, very fast.
+--
+
+tFieldEd
+ :: (Functor m, MonadIO m, Executable m,
+ FormInput v) =>
+ UserStr -> Key -> v -> View v m ()
+tFieldEd muser k text= wfreeze k 0 $ do
+ content <- liftIO $ readtField text k
+ nam <- genNewId
+ let ipanel= nam++"panel"
+ name= nam++"-"++k
+ install= "installEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n"
+ getTexts :: (Token -> IO ())
+ getTexts token = do
+ let (k,s):_ = tenv token
+ liftIO $ do
+ writetField k $ (fromStrNoEncode s `asTypeOf` text)
+ flushCached k
+ sendFlush token $ HttpData [] [] ""
+ return()
+
+ requires [JScriptFile nicEditUrl [install]
+ ,JScript ajaxSendText
+ ,JScript installEditField
+ ,ServerProc ("_texts", transient getTexts)]
us <- getCurrentUser
when(us== muser) noCache
-
- (ftag "div" mempty `attrs` [("id",ipanel)]) ++>
- notValid (ftag "span" content `attrs` [("id", name)])
-
-
-
-installEditField=
- "\nfunction installEditField(muser,cookieuser,name,ipanel){\
- \if(muser== '' || document.cookie.search(cookieuser+'='+muser) != -1)\
- \bkLib.onDomLoaded(function() {\
- \var myNicEditor = new nicEditor({fullPanel : true, onSave : function(content, id, instance) {\
- \ajaxSendText(id,content);\
- \myNicEditor.removeInstance(name);\
- \myNicEditor.removePanel(ipanel);\
- \}});\
- \myNicEditor.addInstance(name);\
- \myNicEditor.setPanel(ipanel);\
- \})};\n"
-
-ajaxSendText = "\nfunction ajaxSendText(id,content){\
- \var arr= id.split('-');\
- \var k= arr[1];\
- \$.ajax({\
- \type: 'POST',\
- \url: '/_texts',\
- \data: k + '='+ encodeURIComponent(content),\
- \success: function (resp) {},\
- \error: function (xhr, status, error) {\
- \var msg = $('<div>' + xhr + '</div>');\
- \id1.html(msg);\
- \}\
- \});\
- \return false;\
- \};\n"
-
--- | a text field. Read the cached field value and present it without edition.
-tField :: (MonadIO m,Functor m, Executable m, FormInput v)
- => Key
- -> View v m ()
-tField k = wfreeze k 0 $ do
- content <- liftIO $ readtField (fromStrNoEncode "not found") k
- notValid content
-
--- | A multilanguage version of tFieldEd. For a field with @key@ it add a suffix with the
--- two characters of the language used.
-mFieldEd muser k content= do
- lang <- getLang
- tFieldEd muser (k ++ ('-':lang)) content
-
-
-
--- | A multilanguage version of tField
-mField k= do
- lang <- getLang
- tField $ k ++ ('-':lang)
-
-newtype IteratedId= IteratedId String deriving Typeable
-
--- | Permits to iterate the presentation of data and//or input fields and widgets within
--- a web page that does not change. The placeholders are created with dField. Both are widget
--- modifiers: The latter gets a widget and create a placeholder in the page that is updated
--- via ajax. The content of the update is the rendering of the widget at each iteration.
--- The former gets a wider widget which contains dField elements and permit the iteration.
--- Whenever a link or a form within the witerate widget is activated, the result is the
--- placeholders filled with the new html content. This content can be data, a input field,
--- a link or a widget. No navigation happens.
---
--- This permits even faster updates than autoRefresh. since the latter refresh the whole
--- widget and it does not permits modifications of the layout at runtime.
---
--- When edTemplate or template is used on top of witerate, the result is editable at runtime,
--- and the span placeholders generated, that are updated via ajax can be relocated within
--- the layout of the template.
---
--- Additionally, contrary to some javascript frameworks, the pages generated with this
--- mechanism are searchable by web crawlers.
-
-witerate
- :: (MonadIO m, Functor m, FormInput v) =>
- View v m a -> View v m a
-witerate w= do
- name <- genNewId
- setSessionData $ IteratedId name
- st <- get
- let t= mfkillTime st
- let installAutoEval=
- "$(document).ready(function(){\
- \autoEvalLink('"++name++"',0);\
- \autoEvalForm('"++name++"');\
- \})\n"
+
+ (ftag "div" mempty `attrs` [("id",ipanel)]) ++>
+ notValid (ftag "span" content `attrs` [("id", name)])
+
+
+
+installEditField=
+ "\nfunction installEditField(muser,cookieuser,name,ipanel){\
+ \if(muser== '' || document.cookie.search(cookieuser+'='+muser) != -1){\
+ \var myNicEditor = new nicEditor({fullPanel : true, onSave : function(content, id, instance) {\
+ \ajaxSendText(id,content);\
+ \myNicEditor.removeInstance(name);\
+ \myNicEditor.removePanel(ipanel);\
+ \}});\
+ \myNicEditor.addInstance(name);\
+ \myNicEditor.setPanel(ipanel);\
+ \}};\n"
+
+ajaxSendText = "\nfunction ajaxSendText(id,content){\
+ \var arr= id.split('-');\
+ \var k= arr[1];\
+ \$.ajax({\
+ \type: 'POST',\
+ \url: '/_texts',\
+ \data: k + '='+ encodeURIComponent(content),\
+ \success: function (resp) {},\
+ \error: function (xhr, status, error) {\
+ \var msg = $('<div>' + xhr + '</div>');\
+ \id1.html(msg);\
+ \}\
+ \});\
+ \return false;\
+ \};\n"
+
+-- | a text field. Read the cached field value and present it without edition.
+tField :: (MonadIO m,Functor m, Executable m, FormInput v)
+ => Key
+ -> View v m ()
+tField k = wfreeze k 0 $ do
+ content <- liftIO $ readtField (fromStrNoEncode "not found") k
+ notValid content
+
+-- | A multilanguage version of tFieldEd. For a field with @key@ it add a suffix with the
+-- two characters of the language used.
+mFieldEd muser k content= do
+ lang <- getLang
+ tFieldEd muser (k ++ ('-':lang)) content
+
+
+
+-- | A multilanguage version of tField
+mField k= do
+ lang <- getLang
+ tField $ k ++ ('-':lang)
+
+data IteratedId = IteratedId String String deriving (Typeable, Show)
+
+-- | Permits to iterate the presentation of data and//or input fields and widgets within
+-- a web page that does not change. The placeholders are created with dField. Both are widget
+-- modifiers: The latter gets a widget and create a placeholder in the page that is updated
+-- via ajax. The content of the update is the rendering of the widget at each iteration.
+-- The former gets a wider widget which contains dField elements and permit the iteration.
+-- Whenever a link or a form within the witerate widget is activated, the result is the
+-- placeholders filled with the new html content. This content can be data, a input field,
+-- a link or a widget. No navigation happens.
+--
+-- This permits even faster updates than autoRefresh. since the latter refresh the whole
+-- widget and it does not permits modifications of the layout at runtime.
+--
+-- When edTemplate or template is used on top of witerate, the result is editable at runtime,
+-- and the span placeholders generated, that are updated via ajax can be relocated within
+-- the layout of the template.
+--
+-- Additionally, contrary to some javascript frameworks, the pages generated with this
+-- mechanism are searchable by web crawlers.
+
+witerate
+ :: (MonadIO m, Functor m, FormInput v) =>
+ View v m a -> View v m a
+witerate w= do
+ name <- genNewId
+ setSessionData $ IteratedId name mempty
+ st <- get
+ let t= mfkillTime st
+ let installAutoEval=
+ "$(document).ready(function(){\
+ \autoEvalLink('"++name++"',0);\
+ \autoEvalForm('"++name++"');\
+ \})\n"
let r = lookup ("auto"++name) $ mfEnv st
w'= w `wcallback` (const $ do
+ setSessionData $ IteratedId name mempty
modify $ \s -> s{mfPagePath=mfPagePath st
,mfSequence= mfSequence st
- ,mfRequirements= if r== Nothing then mfRequirements s else []
,mfHttpHeaders=[]}
- w)
-
- ret <- case r of
- Nothing -> do
- requires [JScript autoEvalLink
- ,JScript autoEvalForm
- ,JScript $ timeoutscript t
+ w)
+
+ ret <- case r of
+ Nothing -> do
+ requires [JScript autoEvalLink
+ ,JScript autoEvalForm
+ ,JScript $ timeoutscript t
,JScriptFile jqueryScript [installAutoEval]
- ,JScript setId]
-
- (ftag "div" <<< w') <! [("id",name)]
-
- Just sind -> View $ do
- let t= mfToken st
- modify $ \s -> s{mfRequirements=[],mfHttpHeaders=[]} -- !> "just"
- resetCachePolicy
- FormElm _ mr <- runView w'
- setCachePolicy
- reqs <- return . map ( \(Requirement r) -> unsafeCoerce r) =<< gets mfRequirements
- let js = jsRequirements True reqs
-
- st' <- get
- liftIO . sendFlush t $ HttpData
- (mfHttpHeaders st')
- (mfCookies st') (fromString js)
- put st'{mfAutorefresh=True, inSync=True}
- return $ FormElm mempty Nothing
-
- delSessionData $ IteratedId name
+ ,JScript setId]
+
+ (ftag "div" <<< w') <! [("id",name)]
+
+ Just sind -> refresh $ View $ do
+ FormElm _ mr <- runView w'
+ IteratedId _ render <- getSessionData `onNothing` return (IteratedId name mempty)
+ return $ FormElm (fromStrNoEncode render) mr
+
+-- View $ do
+-- let t= mfToken st
+-- modify $ \s -> s{mfRequirements=[],mfHttpHeaders=[]} -- !> "just"
+-- resetCachePolicy
+-- FormElm _ mr <- runView w'
+-- setCachePolicy
+--
+-- reqs <- installAllRequirements
+--
+-- st' <- get
+-- liftIO . sendFlush t $ HttpData
+-- (mfHttpHeaders st')
+-- (mfCookies st') (toByteString reqs)
+-- put st'{mfAutorefresh=True, inSync=True}
+-- return $ FormElm mempty Nothing
+
+ delSessionData $ IteratedId name mempty
return ret
-
-autoEvalLink = "\nfunction autoEvalLink(id,ind){\
- \var id1= $('#'+id);\
+
+autoEvalLink = "\nfunction autoEvalLink(id,ind){\
+ \var id1= $('#'+id);\
\var ida= $('#'+id+' a[class!=\"_noAutoRefresh\"]');\
- \ida.off('click');\
- \ida.click(function () {\
- \if (hadtimeout == true) return true;\
- \var pdata = $(this).attr('data-value');\
- \var actionurl = $(this).attr('href');\
- \var dialogOpts = {\
+ \ida.off('click');\
+ \ida.click(function () {\
+ \if (hadtimeout == true) return true;\
+ \var pdata = $(this).attr('data-value');\
+ \var actionurl = $(this).attr('href');\
+ \var dialogOpts = {\
\type: 'GET',\
- \url: actionurl+'?auto'+id+'='+ind,\
- \data: pdata,\
- \success: function (resp) {\
+ \url: actionurl+'?auto'+id+'='+ind,\
+ \data: pdata,\
+ \success: function (resp) {\
\eval(resp);\
\autoEvalLink(id,ind);\
- \autoEvalForm(id);\
- \},\
- \error: function (xhr, status, error) {\
- \var msg = $('<div>' + xhr + '</div>');\
- \id1.html(msg);\
- \}\
- \};\
- \$.ajax(dialogOpts);\
- \return false;\
- \});\
- \}\n"
+ \autoEvalForm(id);\
+ \},\
+ \error: function (xhr, status, error) {\
+ \var msg = $('<div>' + xhr + '</div>');\
+ \id1.html(msg);\
+ \}\
+ \};\
+ \$.ajax(dialogOpts);\
+ \return false;\
+ \});\
+ \}\n"
autoEvalForm = "\nfunction autoEvalForm(id) {\
\var buttons= $('#'+id+' input[type=\"submit\"]');\
@@ -736,12 +739,12 @@
\if ($(this).attr('class') != '_noAutoRefresh'){\
\event.preventDefault();\
\if (hadtimeout == true) return true;\
- \var $form = $(this).closest('form');\
+ \var $form = $(this).closest('form');\
\var url = $form.attr('action');\
\pdata = 'auto'+id+'=true&'+this.name+'='+this.value+'&'+$form.serialize();\
\postForm(id,url,pdata);\
\return false;\
- \}else {\
+ \}else {\
\noajax= true;\
\return true;\
\}\
@@ -751,7 +754,7 @@
\idform.submit(function(event) {\
\if(noajax) {noajax=false; return true;}\
\event.preventDefault();\
- \var $form = $(this);\
+ \var $form = $(this);\
\var url = $form.attr('action');\
\var pdata = 'auto'+id+'=true&' + $form.serialize();\
\postForm(id,url,pdata);\
@@ -759,290 +762,291 @@
\}\
\function postForm(id,url,pdata){\
\var id1= $('#'+id);\
- \$.ajax({\
- \type: 'POST',\
- \url: url,\
- \data: 'auto'+id+'=true&'+this.name+'='+this.value+'&'+pdata,\
- \success: function (resp) {\
+ \$.ajax({\
+ \type: 'POST',\
+ \url: url,\
+ \data: 'auto'+id+'=true&'+this.name+'='+this.value+'&'+pdata,\
+ \success: function (resp) {\
\eval(resp);\
\autoEvalLink(id,0);\
- \autoEvalForm(id);\
+ \autoEvalForm(id);\
\},\
- \error: function (xhr, status, error) {\
- \var msg = $('<div>' + xhr + '</div>');\
- \id1.html(msg);\
+ \error: function (xhr, status, error) {\
+ \var msg = $('<div>' + xhr + '</div>');\
+ \id1.html(msg);\
\}\
- \});\
+ \});\
\}"
-
-
-setId= "function setId(id,v){document.getElementById(id).innerHTML= v;};\n"
-
--- | Present a widget via AJAX if it is within a 'witerate' context. In the first iteration it present the
--- widget surrounded by a placeholder. subsequent iterations will send just the javascript code
--- necessary for the refreshing of the placeholder.
-dField
- :: (Monad m, FormInput view) =>
- View view m b -> View view m b
-dField w= View $ do
- id <- genNewId
- FormElm render mx <- runView w
- st <- get
- let env = mfEnv st
-
- IteratedId name <- getSessionData `onNothing` return (IteratedId noid)
- let r = lookup ("auto"++name) env
+
+
+setId= "function setId(id,v){document.getElementById(id).innerHTML= v;};\n"
+
+-- | Present a widget via AJAX if it is within a 'witerate' context. In the first iteration it present the
+-- widget surrounded by a placeholder. subsequent iterations will send just the javascript code
+-- necessary for the refreshing of the placeholder.
+dField
+ :: (Monad m, FormInput view) =>
+ View view m b -> View view m b
+dField w= View $ do
+ id <- genNewId
+ FormElm render mx <- runView w
+ st <- get
+ let env = mfEnv st
+
+ IteratedId name scripts <- getSessionData `onNothing` return (IteratedId noid mempty)
+ let r = lookup ("auto"++name) env
if r == Nothing || (name == noid && newAsk st== True)
- then do
--- requires [JScriptFile jqueryScript ["$(document).ready(function() {setId('"++id++"','" ++ toString (toByteString render)++"')});\n"]]
- return $ FormElm((ftag "span" render) `attrs` [("id",id)]) mx
- else do
- requires [JScript $ "setId('"++id++"','" ++ toString (toByteString $ render)++"');\n"]
- return $ FormElm mempty mx
-
-noid= "noid"
-
+ then return $ FormElm((ftag "span" render) `attrs` [("id",id)]) mx
+ else do
+ setSessionData $ IteratedId name $ scripts <> "setId('"++id++"','" ++ toString (toByteString $ render)++"');"
+ return $ FormElm mempty mx
+
+noid= "noid"
+
-- | permits the edition of the rendering of a widget at run time. Once saved, the new rendering
-- becomes the new rendering of the widget for all the users. You must keep the active elements of the
-- template
--
-- the first parameter is the user that has permissions for edition. the second is a key that
--- identifies the template.
-edTemplate
- :: (MonadIO m, FormInput v, Typeable a) =>
- UserStr -> Key -> View v m a -> View v m a
-edTemplate muser k w= View $ do
- nam <- genNewId
-
- let ipanel= nam++"panel"
- name= nam++"-"++k
- install= "installEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n"
-
-
- requires [JScriptFile nicEditUrl [install]
- ,JScript ajaxSendText
- ,JScript installEditField
- ,JScriptFile jqueryScript []
- ,ServerProc ("_texts", transient getTexts)]
+-- identifies the template.
+edTemplate
+ :: (MonadIO m, FormInput v, Typeable a) =>
+ UserStr -> Key -> View v m a -> View v m a
+edTemplate muser k w= View $ do
+ nam <- genNewId
+
+ let ipanel= nam++"panel"
+ name= nam++"-"++k
+ install= "installEditField('"++muser++"','"++cookieuser++"','"++name++"','"++ipanel++"');\n"
+
+
+ requires [JScript installEditField
+ ,JScriptFile nicEditUrl [install]
+ ,JScript ajaxSendText
+ ,JScriptFile jqueryScript []
+ ,ServerProc ("_texts", transient getTexts)]
us <- getCurrentUser
- when(us== muser) noCache
- FormElm text mx <- runView w
- content <- liftIO $ readtField text k
-
- return $ FormElm (ftag "div" mempty `attrs` [("id",ipanel)] <>
- ftag "span" content `attrs` [("id", name)])
- mx
- where
- getTexts :: (Token -> IO ())
- getTexts token= do
- let (k,s):_ = tenv token
- liftIO $ do
- writetField k $ (fromStrNoEncode s `asTypeOf` viewFormat w)
- flushCached k
- sendFlush token $ HttpData [] [] ""
- return()
-
- viewFormat :: View v m a -> v
- viewFormat= undefined -- is a type function
-
+ when(us== muser) noCache
+ FormElm text mx <- runView w
+ content <- liftIO $ readtField text k
+
+ return $ FormElm (ftag "div" mempty `attrs` [("id",ipanel)] <>
+ ftag "span" content `attrs` [("id", name)])
+ mx
+ where
+ getTexts :: Token -> IO () -- low level server process
+ getTexts token= do
+ let (k,s):_ = tenv token
+ liftIO $ do
+ writetField k $ (fromStrNoEncode s `asTypeOf` viewFormat w)
+ flushCached k
+ sendFlush token $ HttpData [] [] "" --empty response
+
+ return()
+
+
+ viewFormat :: View v m a -> v
+ viewFormat= undefined -- is a type function
+
-- | Does the same than template but without the edition facility
-template
- :: (MonadIO m, FormInput v, Typeable a) =>
- Key -> View v m a -> View v m a
-template k w= View $ do
- FormElm text mx <- runView w
- let content= unsafePerformIO $ readtField text k
- return $ FormElm content mx
-
-
-
-------------------- JQuery widgets -------------------
--- | present the JQuery datepicker calendar to choose a date.
--- The second parameter is the configuration. Use \"()\" by default.
--- See http://jqueryui.com/datepicker/
-datePicker :: (Monad m, FormInput v) => String -> Maybe String -> View v m (Int,Int,Int)
-datePicker conf jd= do
- id <- genNewId
- let setit= "$(document).ready(function() {\
- \$( '#"++id++"' ).datepicker "++ conf ++";\
- \});"
-
- requires
- [CSSFile jqueryCSS
- ,JScriptFile jqueryScript []
- ,JScriptFile jqueryUI [setit]]
-
- s <- getString jd <! [("id",id)]
- let (month,r) = span (/='/') s
- let (day,r2)= span(/='/') $ tail r
- return (read day,read month, read $ tail r2)
-
--- | present a jQuery dialog with a widget. When a button is pressed it return the result.
--- The first parameter is the configuration. To make it modal, use \"({modal: true})\" see <http://jqueryui.com/dialog/> for
--- the available configurations.
---
--- The enclosed widget will be wrapped within a form tag if the user do not encloses it using wform.f
-wdialog :: (Monad m, FormInput v) => String -> String -> View v m a -> View v m a
-wdialog conf title w= do
- id <- genNewId
- let setit= "$(document).ready(function() {\
- \$('#"++id++"').dialog "++ conf ++";\
- \var idform= $('#"++id++" form');\
- \idform.submit(function(){$(this).dialog(\"close\")})\
- \});"
-
- modify $ \st -> st{needForm= HasForm}
- requires
- [CSSFile jqueryCSS
- ,JScriptFile jqueryScript []
- ,JScriptFile jqueryUI [setit]]
-
- (ftag "div" <<< insertForm w) <! [("id",id),("title", title)]
-
-
-
-
-
--- | Capture the form or link submissions and send them via jQuery AJAX.
--- The response is the new presentation of the widget, that is updated. No new page is generated
--- but the functionality is equivalent. Only the activated widget rendering is updated
--- in the client, so a widget with autoRefresh can be used in heavyweight pages.
--- If AJAX/JavaScript are not available, the widget is refreshed normally, via a new page.
---
--- autoRefresh encloses the widget in a form tag if it includes form elements.
---
--- If there are more than one autoRefresh, they must be enclosed within 'pageFlow' elements
-autoRefresh
- :: (MonadIO m,
- FormInput v)
- => View v m a
- -> View v m a
-autoRefresh = update "html"
-
--- | In some cases, it is neccessary that a link or form inside a 'autoRefresh' or 'update' block
--- should not be autorefreshed, since it produces side effects in the rest of the page that
--- affect to the rendering of the whole. If you like to refresh the whole page, simply add
--- noAutoRefresh attribute to the widget to force the refresh of the whole page when it is activated.
---
--- That behaviour is common at the last sentence of the 'autoRefresh' block.
---
--- This is a cascade menu example.
---
--- > r <- page $ autoRefresh $ ul <<< do
--- > li <<< wlink OptionA << "option A"
--- > ul <<< li <<< (wlink OptionA1 << "Option A1" <! noAutoRefresh)
--- > <|> li <<< (wlink OptionA2 << "Option A2" <! noAutoRefresh)
--- > <|>...
--- > maybe other content
--- >
--- > case r of
--- > OptionA1 -> pageA1
--- > OptionA2 -> pageA2
---
--- when @option A@ is clicked, the two sub-options appear with autorefresh. Only the two
--- lines are returned by the server using AJAX. but when Option A1-2 is pressed we want to
--- present other pages, so we add the noAutorefresh attribute.
---
--- NOTE: the noAutoRefresh attribute should be added to the <a/> or <form/> tags.
-noAutoRefresh= [("class","_noAutoRefresh")]
-
--- | does the same than `autoRefresh` but append the result of each request to the bottom of the widget
---
--- all the comments and remarks of `autoRefresh` apply here
-appendUpdate :: (MonadIO m,
- FormInput v)
- => View v m a
- -> View v m a
-appendUpdate= update "append"
-
--- | does the same than `autoRefresh` but prepend the result of each request before the current widget content
---
--- all the comments and remarks of `autoRefresh` apply here
-prependUpdate :: (MonadIO m,
- FormInput v)
- => View v m a
- -> View v m a
-prependUpdate= update "prepend"
-
-update :: (MonadIO m, FormInput v)
- => B.ByteString
- -> View v m a
- -> View v m a
-update method w= do
- id <- genNewId
+template
+ :: (MonadIO m, FormInput v, Typeable a) =>
+ Key -> View v m a -> View v m a
+template k w= View $ do
+ FormElm text mx <- runView w
+ let content= unsafePerformIO $ readtField text k
+ return $ FormElm content mx
+
+
+
+------------------- JQuery widgets -------------------
+-- | present the JQuery datepicker calendar to choose a date.
+-- The second parameter is the configuration. Use \"()\" by default.
+-- See http://jqueryui.com/datepicker/
+datePicker :: (Monad m, FormInput v) => String -> Maybe String -> View v m (Int,Int,Int)
+datePicker conf jd= do
+ id <- genNewId
+ let setit= "$(document).ready(function() {\
+ \$( '#"++id++"' ).datepicker "++ conf ++";\
+ \});"
+
+ requires
+ [CSSFile jqueryCSS
+ ,JScriptFile jqueryScript []
+ ,JScriptFile jqueryUI [setit]]
+
+ s <- getString jd <! [("id",id)]
+ let (month,r) = span (/='/') s
+ let (day,r2)= span(/='/') $ tail r
+ return (read day,read month, read $ tail r2)
+
+-- | present a jQuery dialog with a widget. When a button is pressed it return the result.
+-- The first parameter is the configuration. To make it modal, use \"({modal: true})\" see <http://jqueryui.com/dialog/> for
+-- the available configurations.
+--
+-- The enclosed widget will be wrapped within a form tag if the user do not encloses it using wform.f
+wdialog :: (Monad m, FormInput v) => String -> String -> View v m a -> View v m a
+wdialog conf title w= do
+ id <- genNewId
+ let setit= "$(document).ready(function() {\
+ \$('#"++id++"').dialog "++ conf ++";\
+ \var idform= $('#"++id++" form');\
+ \idform.submit(function(){$(this).dialog(\"close\")})\
+ \});"
+
+ modify $ \st -> st{needForm= HasForm}
+ requires
+ [CSSFile jqueryCSS
+ ,JScriptFile jqueryScript []
+ ,JScriptFile jqueryUI [setit]]
+
+ (ftag "div" <<< insertForm w) <! [("id",id),("title", title)]
+
+
+
+
+
+-- | Capture the form or link submissions and send them via jQuery AJAX.
+-- The response is the new presentation of the widget, that is updated. No new page is generated
+-- but the functionality is equivalent. Only the activated widget rendering is updated
+-- in the client, so a widget with autoRefresh can be used in heavyweight pages.
+-- If AJAX/JavaScript are not available, the widget is refreshed normally, via a new page.
+--
+-- autoRefresh encloses the widget in a form tag if it includes form elements.
+--
+-- If there are more than one autoRefresh, they must be enclosed within 'pageFlow' elements
+autoRefresh
+ :: (MonadIO m,
+ FormInput v)
+ => View v m a
+ -> View v m a
+autoRefresh = update "html"
+
+-- | In some cases, it is neccessary that a link or form inside a 'autoRefresh' or 'update' block
+-- should not be autorefreshed, since it produces side effects in the rest of the page that
+-- affect to the rendering of the whole. If you like to refresh the whole page, simply add
+-- noAutoRefresh attribute to the widget to force the refresh of the whole page when it is activated.
+--
+-- That behaviour is common at the last sentence of the 'autoRefresh' block.
+--
+-- This is a cascade menu example.
+--
+-- > r <- page $ autoRefresh $ ul <<< do
+-- > li <<< wlink OptionA << "option A"
+-- > ul <<< li <<< (wlink OptionA1 << "Option A1" <! noAutoRefresh)
+-- > <|> li <<< (wlink OptionA2 << "Option A2" <! noAutoRefresh)
+-- > <|>...
+-- > maybe other content
+-- >
+-- > case r of
+-- > OptionA1 -> pageA1
+-- > OptionA2 -> pageA2
+--
+-- when @option A@ is clicked, the two sub-options appear with autorefresh. Only the two
+-- lines are returned by the server using AJAX. but when Option A1-2 is pressed we want to
+-- present other pages, so we add the noAutorefresh attribute.
+--
+-- NOTE: the noAutoRefresh attribute should be added to the <a/> or <form/> tags.
+noAutoRefresh= [("class","_noAutoRefresh")]
+
+-- | does the same than `autoRefresh` but append the result of each request to the bottom of the widget
+--
+-- all the comments and remarks of `autoRefresh` apply here
+appendUpdate :: (MonadIO m,
+ FormInput v)
+ => View v m a
+ -> View v m a
+appendUpdate= update "append"
+
+-- | does the same than `autoRefresh` but prepend the result of each request before the current widget content
+--
+-- all the comments and remarks of `autoRefresh` apply here
+prependUpdate :: (MonadIO m,
+ FormInput v)
+ => View v m a
+ -> View v m a
+prependUpdate= update "prepend"
+
+update :: (MonadIO m, FormInput v)
+ => String
+ -> View v m a
+ -> View v m a
+update method w= do
+ id <- genNewId
st <- get
-
- let t = mfkillTime st -1
-
- installscript=
- "$(document).ready(function(){\
- \ajaxGetLink('"++id++"');\
- \ajaxPostForm('"++id++"');\
+
+ let t = mfkillTime st -1
+
+ installscript=
+ "$(document).ready(function(){\
+ \ajaxGetLink('"++id++"');\
+ \ajaxPostForm('"++id++"');\
\});"
st <- get
let insync = inSync st
- let env= mfEnv st
- let r= lookup ("auto"++id) env
+ let env= mfEnv st
+ let r= lookup ("auto"++id) env
if r == Nothing
- then do
- requires [JScript $ timeoutscript t
- ,JScript ajaxGetLink
- ,JScript ajaxPostForm
- ,JScriptFile jqueryScript [installscript]]
- (ftag "div" <<< insertForm w) <! [("id",id)]
-
- else View $ do
- let t= mfToken st -- !> "JUST"
- modify $ \s -> s{mfHttpHeaders=[]} -- !> "just"
- resetCachePolicy
- FormElm form mr <- runView $ insertForm w
- setCachePolicy
- st' <- get
- let HttpData ctype c s= toHttpData $ method <> " " <> toByteString form
-
- (liftIO . sendFlush t $ HttpData (ctype ++
- mfHttpHeaders st') (mfCookies st' ++ c) s)
- put st'{mfAutorefresh=True,newAsk=True}
-
- return $ FormElm mempty Nothing
-
- where
- -- | adapted from http://www.codeproject.com/Articles/341151/Simple-AJAX-POST-Form-and-AJAX-Fetch-Link-to-Modal
+ then do
+ requires [JScript $ timeoutscript t
+ ,JScript ajaxGetLink
+ ,JScript ajaxPostForm
+ ,JScriptFile jqueryScript [installscript]]
+ (ftag "div" <<< insertForm w) <! [("id",id)]
+
+ else refresh $ fromStr (method <> " ") ++> insertForm w
+-- View $ do
+-- let t= mfToken st -- !> "JUST"
+-- modify $ \s -> s{mfHttpHeaders=[]} -- !> "just"
+-- resetCachePolicy
+-- FormElm form mr <- runView $ insertForm w
+-- setCachePolicy
+-- st' <- get
+-- let HttpData ctype c s= toHttpData $ method <> " " <> toByteString form
+--
+-- (liftIO . sendFlush t $ HttpData (ctype ++
+-- mfHttpHeaders st') (mfCookies st' ++ c) s)
+-- put st'{mfAutorefresh=True,newAsk=True}
+--
+-- return $ FormElm mempty Nothing
+
+ where
+ -- | adapted from http://www.codeproject.com/Articles/341151/Simple-AJAX-POST-Form-and-AJAX-Fetch-Link-to-Modal
-- \url: actionurl+'?bustcache='+ new Date().getTime()+'&auto'+id+'=true',\n\
ajaxGetLink = "\nfunction ajaxGetLink(id){\
- \var id1= $('#'+id);\
+ \var id1= $('#'+id);\
\var ida= $('#'+id+' a[class!=\"_noAutoRefresh\"]');\
- \ida.off('click');\
- \ida.click(function () {\
- \if (hadtimeout == true) return true;\
- \var pdata = $(this).attr('data-value');\
- \var actionurl = $(this).attr('href');\
- \var dialogOpts = {\
+ \ida.off('click');\
+ \ida.click(function () {\
+ \if (hadtimeout == true) return true;\
+ \var pdata = $(this).attr('data-value');\
+ \var actionurl = $(this).attr('href');\
+ \var dialogOpts = {\
\type: 'GET',\
- \url: actionurl+'?auto'+id+'=true',\
- \data: pdata,\
- \success: function (resp) {\
- \var ind= resp.indexOf(' ');\
- \var dat= resp.substr(ind);\
- \var method= resp.substr(0,ind);\
- \if(method== 'html')id1.html(dat);\
- \else if (method == 'append') id1.append(dat);\
+ \url: actionurl+'?auto'+id+'=true',\
+ \data: pdata,\
+ \success: function (resp) {\
+ \var ind= resp.indexOf(' ');\
+ \var dat= resp.substr(ind);\
+ \var method= resp.substr(0,ind);\
+ \if(method== 'html')id1.html(dat);\
+ \else if (method == 'append') id1.append(dat);\
\else if (method == 'prepend') id1.prepend(dat);\
- \else $(':root').html(resp);\
+ \else $(':root').html(resp);\
\ajaxGetLink(id);\
- \ajaxPostForm(id);\
- \},\
- \error: function (xhr, status, error) {\
- \var msg = $('<div>' + xhr + '</div>');\
- \id1.html(msg);\
- \}\
- \};\
- \$.ajax(dialogOpts);\
- \return false;\
- \});\
- \}\n"
+ \ajaxPostForm(id);\
+ \},\
+ \error: function (xhr, status, error) {\
+ \var msg = $('<div>' + xhr + '</div>');\
+ \id1.html(msg);\
+ \}\
+ \};\
+ \$.ajax(dialogOpts);\
+ \return false;\
+ \});\
+ \}\n"
ajaxPostForm = "\nfunction ajaxPostForm(id) {\
\var buttons= $('#'+id+' input[type=\"submit\"]');\
@@ -1051,13 +1055,13 @@
\buttons.click(function(event) {\
\if ($(this).attr('class') != '_noAutoRefresh'){\
\event.preventDefault();\
- \if (hadtimeout == true) return true;\
- \var $form = $(this).closest('form');\
+ \if (hadtimeout == true) return true;\
+ \var $form = $(this).closest('form');\
\var url = $form.attr('action');\
\pdata = 'auto'+id+'=true&'+this.name+'='+this.value+'&'+$form.serialize();\
\postForm(id,url,pdata);\
\return false;\
- \}else {\
+ \}else {\
\noajax= true;\
\return true;\
\}\
@@ -1067,197 +1071,197 @@
\idform.submit(function(event) {\
\if(noajax) {noajax=false; return true;}\
\event.preventDefault();\
- \var $form = $(this);\
+ \var $form = $(this);\
\var url = $form.attr('action');\
\var pdata = 'auto'+id+'=true&' + $form.serialize();\
\postForm(id,url,pdata);\
\return false;})\
\}\
\function postForm(id,url,pdata){\
- \var id1= $('#'+id);\
- \$.ajax({\
- \type: 'POST',\
- \url: url,\
- \data: pdata,\
- \success: function (resp) {\
- \var ind= resp.indexOf(' ');\
- \var dat = resp.substr(ind);\
- \var method= resp.substr(0,ind);\
- \if(method== 'html')id1.html(dat);\
- \else if (method == 'append') id1.append(dat);\
+ \var id1= $('#'+id);\
+ \$.ajax({\
+ \type: 'POST',\
+ \url: url,\
+ \data: pdata,\
+ \success: function (resp) {\
+ \var ind= resp.indexOf(' ');\
+ \var dat = resp.substr(ind);\
+ \var method= resp.substr(0,ind);\
+ \if(method== 'html')id1.html(dat);\
+ \else if (method == 'append') id1.append(dat);\
\else if (method == 'prepend') id1.prepend(dat);\
\else $(':root').html(resp);\
- \ajaxGetLink(id);\
- \ajaxPostForm(id);\
- \},\
- \error: function (xhr, status, error) {\
- \var msg = $('<div>' + xhr + '</div>');\
- \id1.html(msg);\
- \}\
- \});\
- \};"
-
-
-
-
-timeoutscript t=
- "\nvar hadtimeout=false;\
- \if("++show t++" > 0)setTimeout(function() {hadtimeout=true; }, "++show (t*1000)++");\n"
-
-
-data UpdateMethod= Append | Prepend | Html deriving Show
-
--- | continously execute a widget and update the content.
--- The update method specify how the update is done. 'Html' means a substitution of content.
--- The second parameter is the delay for the next retry in case of disconnection, in milliseconds.
---
--- It can be used to show data updates in the server. The widget is executed in a different process than
--- the one of the rest of the page.
--- Updates in the session context are not seen by the push widget. It has his own context.
--- To communicate with te widget, use DBRef's or TVar and the
--- STM semantics for waiting updates using 'retry'.
---
--- Widgets in a push can have links and forms, but since they are asunchonous, they can not
--- return inputs. but they can modify the server state.
--- push ever return an invalid response to the calling widget, so it never
--- triggers the advance of the navigation.
---
---
--- This example is a counter increased each second:
---
--- > pushIncrease= do
--- > tv <- liftIO $ newTVarIO 0
--- > page $ push 0 Html $ do
--- > n <- atomic $ readTVar tv
--- > atomic $ writeTVar tv $ n + 1
--- > liftIO $ threadDelay 1000000
--- > b << (show n) ++> noWidget
---
---
--- This other simulates a console output that echoes what is entered in a text box
--- below. It has two widgets: a push output in append mode and a text box input.
--- The communication uses a TVar. The push widget wait for updates in the TVar.
--- because the second widget uses autoRefresh, all happens in the same page.
---
--- It is recommended to add a timeout to the push widget, like in the example:
---
--- > pushSample= do
--- > tv <- liftIO $ newTVarIO $ Just "init"
--- > page $ push Append 1000 (disp tv) <** input tv
--- >
--- > where
--- > disp tv= do
--- > setTimeouts 100 0
--- > line <- tget tv
--- > p << line ++> noWidget
--- >
--- > input tv= autoRefresh $ do
--- > line <- getString Nothing <** submitButton "Enter"
--- > tput tv line
--- >
--- > tput tv x = atomic $ writeTVar tv ( Just x) !> "WRITE"
--- >
--- > tget tv= atomic $ do
--- > mr <- readTVar tv
--- > case mr of
--- > Nothing -> retry
--- > Just r -> do
--- > writeTVar tv Nothing
--- > return r
-
-push :: FormInput v
- => UpdateMethod
- -> Int
- -> View v IO ()
- -> View v IO ()
-push method' wait w= push' . map toLower $ show method'
- where
- push' method= do
- id <- genNewId
- st <- get
- let token= mfToken st
-
- procname= "_push" ++ tind token ++ id
- installscript=
- "$(document).ready(function(){\n"
- ++ "ajaxPush('"++id++"',"++show wait++");"
- ++ "})\n"
-
- new <- gets newAsk
-
- when new $ do
- killWF procname token{twfname= procname}
- let proc=runFlow . transientNav . ask $ w'
- requires [ServerProc (procname, proc),
- JScript $ ajaxPush procname,
- JScriptFile jqueryScript [installscript]]
-
- (ftag "div" <<< noWidget) <! [("id",id)]
- <++ ftag "div" mempty `attrs` [("id",id++"status")]
-
- where
- w' = do
- modify $ \s -> s{inSync= True,newAsk=True}
- w
-
-
-
- ajaxPush procname=" function ajaxPush(id,waititime){\
- \var cnt=0; \
- \var id1= $('#'+id);\
- \var idstatus= $('#'+id+'status');\
- \var ida= $('#'+id+' a');\
- \var actionurl='/"++procname++"';\
- \var dialogOpts = {\
- \cache: false,\
- \type: 'GET',\
- \url: actionurl,\
- \data: '',\
- \success: function (resp) {\
- \idstatus.html('')\
- \cnt=0;\
- \id1."++method++"(resp);\
- \ajaxPush1();\
- \},\
- \error: function (xhr, status, error) {\
- \cnt= cnt + 1;\
- \if (false) \
- \idstatus.html('no more retries');\
- \else {\
- \idstatus.html('waiting');\
- \setTimeout(function() { idstatus.html('retrying');ajaxPush1(); }, waititime);\
- \}\
- \}\
- \};\
- \function ajaxPush1(){\
- \$.ajax(dialogOpts);\
- \return false;\
- \}\
- \ajaxPush1();\
- \}"
-
-
-
-
--- | show the jQuery spinner widget. the first parameter is the configuration . Use \"()\" by default.
--- See http://jqueryui.com/spinner
-getSpinner
- :: (MonadIO m, Read a,Show a, Typeable a, FormInput view) =>
- String -> Maybe a -> View view m a
-getSpinner conf mv= do
- id <- genNewId
- let setit= "$(document).ready(function() {\
- \var spinner = $( '#"++id++"' ).spinner "++conf++";\
- \spinner.spinner( \"enable\" );\
- \});"
- requires
- [CSSFile jqueryCSS
- ,JScriptFile jqueryScript []
- ,JScriptFile jqueryUI [setit]]
-
- getTextBox mv <! [("id",id)]
+ \ajaxGetLink(id);\
+ \ajaxPostForm(id);\
+ \},\
+ \error: function (xhr, status, error) {\
+ \var msg = $('<div>' + xhr + '</div>');\
+ \id1.html(msg);\
+ \}\
+ \});\
+ \};"
+
+
+
+
+timeoutscript t=
+ "\nvar hadtimeout=false;\
+ \if("++show t++" > 0)setTimeout(function() {hadtimeout=true; }, "++show (t*1000)++");\n"
+
+
+data UpdateMethod= Append | Prepend | Html deriving Show
+
+-- | continously execute a widget and update the content.
+-- The update method specify how the update is done. 'Html' means a substitution of content.
+-- The second parameter is the delay for the next retry in case of disconnection, in milliseconds.
+--
+-- It can be used to show data updates in the server. The widget is executed in a different process than
+-- the one of the rest of the page.
+-- Updates in the session context are not seen by the push widget. It has his own context.
+-- To communicate with te widget, use DBRef's or TVar and the
+-- STM semantics for waiting updates using 'retry'.
+--
+-- Widgets in a push can have links and forms, but since they are asunchonous, they can not
+-- return inputs. but they can modify the server state.
+-- push ever return an invalid response to the calling widget, so it never
+-- triggers the advance of the navigation.
+--
+--
+-- This example is a counter increased each second:
+--
+-- > pushIncrease= do
+-- > tv <- liftIO $ newTVarIO 0
+-- > page $ push 0 Html $ do
+-- > n <- atomic $ readTVar tv
+-- > atomic $ writeTVar tv $ n + 1
+-- > liftIO $ threadDelay 1000000
+-- > b << (show n) ++> noWidget
+--
+--
+-- This other simulates a console output that echoes what is entered in a text box
+-- below. It has two widgets: a push output in append mode and a text box input.
+-- The communication uses a TVar. The push widget wait for updates in the TVar.
+-- because the second widget uses autoRefresh, all happens in the same page.
+--
+-- It is recommended to add a timeout to the push widget, like in the example:
+--
+-- > pushSample= do
+-- > tv <- liftIO $ newTVarIO $ Just "init"
+-- > page $ push Append 1000 (disp tv) <** input tv
+-- >
+-- > where
+-- > disp tv= do
+-- > setTimeouts 100 0
+-- > line <- tget tv
+-- > p << line ++> noWidget
+-- >
+-- > input tv= autoRefresh $ do
+-- > line <- getString Nothing <** submitButton "Enter"
+-- > tput tv line
+-- >
+-- > tput tv x = atomic $ writeTVar tv ( Just x) !> "WRITE"
+-- >
+-- > tget tv= atomic $ do
+-- > mr <- readTVar tv
+-- > case mr of
+-- > Nothing -> retry
+-- > Just r -> do
+-- > writeTVar tv Nothing
+-- > return r
+
+push :: FormInput v
+ => UpdateMethod
+ -> Int
+ -> View v IO ()
+ -> View v IO ()
+push method' wait w= push' . map toLower $ show method'
+ where
+ push' method= do
+ id <- genNewId
+ st <- get
+ let token= mfToken st
+
+ procname= "_push" ++ tind token ++ id
+ installscript=
+ "$(document).ready(function(){\n"
+ ++ "ajaxPush('"++id++"',"++show wait++");"
+ ++ "})\n"
+
+ new <- gets newAsk
+
+ when new $ do
+ killWF procname token{twfname= procname}
+ let proc=runFlow . transientNav . ask $ w'
+ requires [ServerProc (procname, proc),
+ JScript $ ajaxPush procname,
+ JScriptFile jqueryScript [installscript]]
+
+ (ftag "div" <<< noWidget) <! [("id",id)]
+ <++ ftag "div" mempty `attrs` [("id",id++"status")]
+
+ where
+ w' = do
+ modify $ \s -> s{inSync= True,newAsk=True}
+ w
+
+
+
+ ajaxPush procname=" function ajaxPush(id,waititime){\
+ \var cnt=0; \
+ \var id1= $('#'+id);\
+ \var idstatus= $('#'+id+'status');\
+ \var ida= $('#'+id+' a');\
+ \var actionurl='/"++procname++"';\
+ \var dialogOpts = {\
+ \cache: false,\
+ \type: 'GET',\
+ \url: actionurl,\
+ \data: '',\
+ \success: function (resp) {\
+ \idstatus.html('');\
+ \cnt=0;\
+ \id1."++method++"(resp);\
+ \ajaxPush1();\
+ \},\
+ \error: function (xhr, status, error) {\
+ \cnt= cnt + 1;\
+ \if (false) \
+ \idstatus.html('no more retries');\
+ \else {\
+ \idstatus.html('waiting');\
+ \setTimeout(function() { idstatus.html('retrying');ajaxPush1(); }, waititime);\
+ \}\
+ \}\
+ \};\
+ \function ajaxPush1(){\
+ \$.ajax(dialogOpts);\
+ \return false;\
+ \}\
+ \ajaxPush1();\
+ \}"
+
+
+
+
+-- | show the jQuery spinner widget. the first parameter is the configuration . Use \"()\" by default.
+-- See http://jqueryui.com/spinner
+getSpinner
+ :: (MonadIO m, Read a,Show a, Typeable a, FormInput view) =>
+ String -> Maybe a -> View view m a
+getSpinner conf mv= do
+ id <- genNewId
+ let setit= "$(document).ready(function() {\
+ \var spinner = $( '#"++id++"' ).spinner "++conf++";\
+ \spinner.spinner( \"enable\" );\
+ \});"
+ requires
+ [CSSFile jqueryCSS
+ ,JScriptFile jqueryScript []
+ ,JScriptFile jqueryUI [setit]]
+
+ getTextBox mv <! [("id",id)]
+
-
-- | takes as argument a widget and delay the load until it is visible. The renderring to
-- be shown during the load is the specified in the first parameter. The resulting lazy
@@ -1277,50 +1281,31 @@
--
-- lazy temprendering $ img ! href imageurl ++> noWidget
lazy :: (FormInput v,Functor m,MonadIO m) => v -> View v m a -> View v m a
-lazy v w= do
- id <- genNewId
+lazy v w= do
+ id <- genNewId
st <- get
let path = currentPath st
- env = mfEnv st
- r= lookup ("auto"++id) env
- t = mfkillTime st -1
+ env = mfEnv st
+ r= lookup ("auto"++id) env
+ t = mfkillTime st -1
installscript = "$(document).ready(function(){\
\function lazyexec(){lazy('"++id++"','"++ path ++"',lazyexec)};\
\$(window).one('scroll',lazyexec);\
\$(window).trigger('scroll');\
\});"
--- installscript2= "$(window).one('scroll',function(){\
--- \function lazyexec(){lazy('"++id++"','"++ path ++"',lazyexec)};\
--- \lazyexec()});"
-
-
- if r == Nothing then View $ do
- requires [JScript lazyScript
+ if r == Nothing then View $ do
+ requires [JScript lazyScript
,JScriptFile jqueryScript [installscript,scrollposition]]
- FormElm rendering mx <- runView w
+ reqs <- gets mfRequirements
+ FormElm _ mx <- runView w
+ modify $ \st-> st{mfRequirements= reqs} --ignore requirements
return $ FormElm (ftag "div" v `attrs` [("id",id)]) mx
-
- else View $ do
- resetCachePolicy
- st' <- get
- FormElm form mx <- runView w
- setCachePolicy
- let t= mfToken st'
- reqs <- installAllRequirements
- let HttpData ctype c s= toHttpData $ toByteString form
- liftIO . sendFlush t $ HttpData (ctype ++
- mfHttpHeaders st') (mfCookies st' ++ c)
- $ toByteString reqs <> s -- !> (unpack $ toByteString reqs)
- put st'{mfAutorefresh=True,inSync= True}
-
- return $ FormElm mempty mx
-
+
+ else refresh w
where
-
-
scrollposition= "$.fn.scrollposition= function(){\
\var pos= $(this).position();\
\if (typeof(pos)==='undefined') {return 1;}\
@@ -1339,24 +1324,37 @@
\lastCall = now;\
\if(id1.scrollposition() > 0){\
\$(window).one('scroll',f);}\
- \else{\
- \var dialogOpts = {\
+ \else{\
+ \var dialogOpts = {\
\type: 'GET',\
- \url: actionurl+'?auto'+id+'=true',\
- \success: function (resp) {\
+ \url: actionurl+'?auto'+id+'=true',\
+ \success: function (resp) {\
\id1.html(resp);\
- \$(window).trigger('scroll');\
+ \$(window).trigger('scroll');\
\},\
- \error: function (xhr, status, error) {\
- \var msg = $('<div>' + xhr + '</div>');\
+ \error: function (xhr, status, error) {\
+ \var msg = $('<div>' + xhr + '</div>');\
\id1.html(msg);\
- \}\
- \};\
- \$.ajax(dialogOpts);\
+ \}\
+ \};\
+ \$.ajax(dialogOpts);\
\}}};"
+refresh w= View $ do
+ resetCachePolicy
+ modify $ \st -> st{mfAutorefresh=True,inSync= True}
+ FormElm form mx <- runView w -- !> show (mfInstalledScripts st')
+ setCachePolicy
+ st' <- get
+ let t= mfToken st'
+ reqs <- installAllRequirements
+ let HttpData ctype c s= toHttpData $ toByteString form
+ liftIO . sendFlush t $ HttpData (ctype ++
+ mfHttpHeaders st') (mfCookies st' ++ c)
+ $ s <> toByteString reqs
+ return $ FormElm mempty mx
-waitAndExecute= "function waitAndExecute(sym,f) {\
- \if (eval(sym)) {f();}\
- \else {setTimeout(function() {waitAndExecute(sym,f)}, 50);}\
- \}\n"
+--waitAndExecute= "function waitAndExecute(sym,f) {\
+-- \if (eval(sym)) {f();}\
+-- \else {setTimeout(function() {waitAndExecute(sym,f)}, 50);}\
+-- \}\n"
diff -ru orig/src/MFlow/Forms/XHtml.hs new/src/MFlow/Forms/XHtml.hs
--- orig/src/MFlow/Forms/XHtml.hs 2014-06-10 05:51:26.973015856 +0300
+++ new/src/MFlow/Forms/XHtml.hs 2014-06-10 05:51:25.000000000 +0300
@@ -1,66 +1,66 @@
------------------------------------------------------------------------------
---
--- Module : Control.MessageFlow.Forms.XHtml
--- Copyright : Alberto Gónez Corona
--- License : BSD3
---
--- Maintainer : agocorona@gmail.com
--- Stability : experimental
---
------------------------------------------------------------------------------
-{- | Instances of `FormInput` for the 'Text.XHtml' module of the xhtml package
--}
-
-{-# OPTIONS -XMultiParamTypeClasses
- -XFlexibleInstances
- -XUndecidableInstances
- -XTypeSynonymInstances
- -XFlexibleContexts
- -XTypeOperators
- #-}
-
-
-module MFlow.Forms.XHtml where
-
-import MFlow (HttpData(..))
-import MFlow.Forms
-import MFlow.Cookies(contentHtml)
-import Data.ByteString.Lazy.Char8(pack,unpack)
-import qualified Data.Text as T
-import Text.XHtml.Strict as X
-import Control.Monad.Trans
-import Data.Typeable
-
-instance Monad m => ADDATTRS (View Html m a) where
- widget ! atrs= widget `wmodify` \fs mx -> return ((head fs ! atrs:tail fs), mx)
-
-
-
-instance FormInput Html where
- toByteString = pack. showHtmlFragment
- toHttpData = HttpData [contentHtml] [] . toByteString
- ftag t= tag t
- inred = X.bold ![X.thestyle "color:red"]
- finput n t v f c= X.input ! ([thetype t ,name n, value v] ++ if f then [checked] else []
- ++ case c of Just s ->[strAttr "onclick" s]; _ -> [] )
- ftextarea name text= X.textarea ! [X.name name] << T.unpack text
-
- fselect name list = select ![ X.name name] << list
- foption name v msel= X.option ! ([value name] ++ selected msel) << v
- where
- selected msel = if msel then [X.selected] else []
-
- attrs tag attrs = tag ! (map (\(n,v) -> strAttr n v) attrs)
-
-
-
- formAction action form = X.form ! [X.action action, method "post"] << form
- fromStr = stringToHtml
- fromStrNoEncode= primHtml
-
- flink v str = toHtml $ hotlink ( v) << str
-
-instance Typeable Html where
- typeOf = \_ -> mkTyConApp (mkTyCon3 "xhtml" "Text.XHtml.Strict" "Html") []
-
-
+-----------------------------------------------------------------------------
+--
+-- Module : Control.MessageFlow.Forms.XHtml
+-- Copyright : Alberto Gónez Corona
+-- License : BSD3
+--
+-- Maintainer : agocorona@gmail.com
+-- Stability : experimental
+--
+-----------------------------------------------------------------------------
+{- | Instances of `FormInput` for the 'Text.XHtml' module of the xhtml package
+-}
+
+{-# OPTIONS -XMultiParamTypeClasses
+ -XFlexibleInstances
+ -XUndecidableInstances
+ -XTypeSynonymInstances
+ -XFlexibleContexts
+ -XTypeOperators
+ #-}
+
+
+module MFlow.Forms.XHtml where
+
+import MFlow (HttpData(..))
+import MFlow.Forms
+import MFlow.Cookies(contentHtml)
+import Data.ByteString.Lazy.Char8(pack,unpack)
+import qualified Data.Text as T
+import Text.XHtml.Strict as X
+import Control.Monad.Trans
+import Data.Typeable
+
+instance Monad m => ADDATTRS (View Html m a) where
+ widget ! atrs= widget `wmodify` \fs mx -> return ((head fs ! atrs:tail fs), mx)
+
+
+
+instance FormInput Html where
+ toByteString = pack. showHtmlFragment
+ toHttpData = HttpData [contentHtml] [] . toByteString
+ ftag t= tag t
+ inred = X.bold ![X.thestyle "color:red"]
+ finput n t v f c= X.input ! ([thetype t ,name n, value v] ++ if f then [checked] else []
+ ++ case c of Just s ->[strAttr "onclick" s]; _ -> [] )
+ ftextarea name text= X.textarea ! [X.name name] << T.unpack text
+
+ fselect name list = select ![ X.name name] << list
+ foption name v msel= X.option ! ([value name] ++ selected msel) << v
+ where
+ selected msel = if msel then [X.selected] else []
+
+ attrs tag attrs = tag ! (map (\(n,v) -> strAttr n v) attrs)
+
+
+
+ formAction action form = X.form ! [X.action action, method "post"] << form
+ fromStr = stringToHtml
+ fromStrNoEncode= primHtml
+
+ flink v str = toHtml $ hotlink ( v) << str
+
+instance Typeable Html where
+ typeOf = \_ -> mkTyConApp (mkTyCon3 "xhtml" "Text.XHtml.Strict" "Html") []
+
+
diff -ru orig/src/MFlow/Forms.hs new/src/MFlow/Forms.hs
--- orig/src/MFlow/Forms.hs 2014-06-10 05:51:26.961015857 +0300
+++ new/src/MFlow/Forms.hs 2014-06-10 05:51:25.000000000 +0300
@@ -1,1039 +1,1047 @@
-{-# OPTIONS -XDeriveDataTypeable
- -XUndecidableInstances
- -XExistentialQuantification
- -XMultiParamTypeClasses
- -XTypeSynonymInstances
- -XFlexibleInstances
- -XScopedTypeVariables
- -XFunctionalDependencies
- -XFlexibleContexts
- -XRecordWildCards
- -XIncoherentInstances
- -XTypeFamilies
- -XTypeOperators
- -XOverloadedStrings
- -XTemplateHaskell
- -XNoMonomorphismRestriction
-
-#-}
-
-{- |
-MFlow run stateful server processes. This version is the first stateful web framework
-that is as RESTful as a web framework can be.
-
-The routes are expressed as normal, monadic haskell code in the FlowM monad. Local links
-point to alternative routes within this monadic computation just like a textual menu
-in a console application. Any GET page is directly reachable by means of a RESTful URL.
-
-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.
-If the procedure is waiting for another different page, the FlowM monad backtrack until the path partially match
-. From this position the execution goes forward until the rest of the path match. This way the
-statelessness is optional. However, it is possible to store a session state, which may backtrack or
-not when the navigation goes back and forth. It is upto the programmer.
-
-
-All the flow of requests and responses are coded by the programmer in a single procedure.
-Allthoug single request-response flows are possible. Therefore, the code is
-more understandable. It is not continuation based. It uses a log for thread state persistence and backtracking for
-handling the back button. Back button state syncronization is supported out-of-the-box
-
-The MFlow architecture is scalable, since the state is serializable and small
-
-The processes are stopped and restarted by the
-application server on demand, including the execution state (if the Wokflow monad is used).
-Therefore session management is automatic. State consistence and transactions are given by the TCache package.
-
-The processes interact trough widgets, that are an extension of formlets with
-additional applicative combinators, formatting, link management, callbacks, modifiers, caching,
-byteString conversion and AJAX. All is coded in pure haskell.
-
-The interfaces and communications are abstract, but there are bindings for blaze-html, HSP, Text.XHtml and byteString
-, Hack and WAI but it can be extended to non Web based architectures.
-
-Bindings for hack, and hsp >= 0.8, are not compiled by Hackage, and do not appear, but are included in the package files.
-To use them, add then to the exported modules and execute cabal install
-
-It is designed for applications that can be run with no deployment with runghc in order
-to speed up the development process. see <http://haskell-web.blogspot.com.es/2013/05/a-web-application-in-tweet.html>
-
-This module implement stateful processes (flows) that are optionally persistent.
-This means that they automatically store and recover his execution state. They are executed by the MFlow app server.
-defined in the "MFlow" module.
-
-These processses interact with the user trough user interfaces made of widgets (see below) that return back statically typed responses to
-the calling process. Because flows are stateful, not request-response, the code is more understandable, because
-all the flow of request and responses is coded by the programmer in a single procedure in the FlowM monad. Allthoug
-single request-response flows and callbacks are possible.
-
-This module is abstract with respect to the formatting (here referred with the type variable @view@) . For an
-instantiation for "Text.XHtml" import "MFlow.Forms.XHtml", "MFlow.Hack.XHtml.All" or "MFlow.Wai.XHtml.All" .
-To use Haskell Server Pages import "MFlow.Forms.HSP". However the functionalities are documented here.
-
-`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.
-It send user interfaces (in the @View view m@ monad) and return statically
-typed responses. The user interface definitions are based on a extension of
-formLets (<http://www.haskell.org/haskellwiki/Formlets>) with the addition of caching, links, formatting, attributes,
- extra combinators, callbaks and modifiers.
-The interaction with the user is stateful. In the same computation there may be many
-request-response interactions, in the same way than in the case of a console applications.
-
-* APPLICATION SERVER
-
-Therefore, session and state management is simple and transparent: it is in the haskell
-structures in the scope of the computation. `transient` (normal) procedures have no persistent session state
-and `stateless` procedures accept a single request and return a single response.
-
-`MFlow.Forms.step` is a lifting monad transformer that permit persistent server procedures that
-remember the execution state even after system shutdowns by using the package workflow (<http://hackage.haskell.org/package/Workflow>) internally.
-This state management is transparent. There is no programer interface for session management.
-
-The programmer set the process timeout and the session timeout with `setTimeouts`.
-If the procedure has been stopped due to the process timeout or due to a system shutdowm,
-the procedure restart in the last state when a request for this procedure arrives
-(if the procedure uses the `step` monad transformer)
-
-* WIDGETS
-
-The correctness of the web responses is assured by the use of formLets.
-But unlike formLets in its current form, it permits the definition of widgets.
-/A widget is a combination of formLets and links within its own formatting template/, all in
-the same definition in the same source file, in plain declarative Haskell style.
-
-The formatting is abstract. It has to implement the 'FormInput' class.
-There are instances for Text.XHtml ("MFlow.Forms.XHtml"), Haskell Server Pages ("MFlow.Forms.HSP")
-and ByteString. So widgets
-can use any formatting that is instance of `FormInput`.
-It is possible to use more than one format in the same widget.
-
-Links defined with `wlink` are treated the same way than forms. They are type safe and return values
- to the same flow of execution.
-It is posssible to combine links and forms in the same widget by using applicative combinators but also
-additional applicative combinators like \<+> !*> , |*|. Widgets are also monoids, so they can
-be combined as such.
-
-* NEW IN THIS RELEASE
-
-[@Runtime templates@] 'template', 'edTemplate', 'witerate' and 'dField' permit the edition of
-the widget content at runtime, and the management of placeholders with input fields and data fields
-within the template with no navigation in the client, little bandwidth usage and little server load. Enven less
-than using 'autoRefresh'.
-
-* IN PREVIOUS RELEASES
-
-{@AutoRefresh@] Using `autoRefresh`, Dynamic widgets can refresh themselves with new information without forcing a refresh of the whole page
-
-[@Push@] With `push` a widget can push new content to the browser when something in the server happens
-
-[@Error traces@] using the monadloc package, now each runtime error (in a monadic statement) has a complete execution trace.
-
-
-[@RESTful URLs@] Now each page is directly reachable by means of a intuitive, RESTful url, whose path is composed by the sucession
-of links clicked to reach such page and such point in the procedure. Just what you would expect.
-
-[@Page flows@] each widget-formlet can have its own independent behaviour within the page. They can
-refresh independently trough AJAX by means of 'autoRefresh'. Additionally, 'pageFlow' initiates the page flow mode or a
-subpage flow by adding a well know indetifier prefix for links and form parameters.
-
-[@Modal Dialogs@] 'wdialog' present a widget within a modal or non modal jQuery dialog. while a monadic
-widget-formlet can add different form elements depending on the user responses, 'wcallback' can
-substitute the widget by other. (See 'Demos/demos.blaze.hs' for some examples)
-
-[@JQuery widgets@] with MFlow interface: 'getSpinner', 'datePicker', 'wdialog'
-
-[@WAI interface@] Now MFlow works with Snap and other WAI developments. Include "MFlow.Wai" or "MFlow.Wai.Blaze.Html.All" to use it.
-
-[@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
-
-[@AJAX@] Now an ajax procedures (defined with 'ajax' can perform many interactions with the browser widgets, instead
-of a single request-response (see 'ajaxSend').
-
-[@Active widgets@] "MFlow.Forms.Widgets" contains active widgets that interact with the
-server via Ajax and dynamically control other widgets: 'wEditList', 'autocomplete' 'autocompleteEdit' and others.
-
-[@Requirements@] a widget can specify javaScript files, JavasScript online scipts, CSS files, online CSS and server processes
- and any other instance of the 'Requrement' class. See 'requires' and 'WebRequirements'
-
-[@content-management@] for templating and online edition of the content template. See 'tFieldEd' 'tFieldGen' and 'tField'
-
-[@multilanguage@] see 'mField' and 'mFieldEd'
-
-[@URLs to internal states@] if the web navigation is trough GET forms or links,
- an URL can express a direct path to the n-th step of a flow, So this URL can be shared with other users.
-Just like in the case of an ordinary stateless application.
-
-
-[@Back Button@] This is probably the first implementation in any language where the navigation
-can be expressed procedurally and still it works well with the back button, thanks
-to monad magic. (See <http://haskell-web.blogspot.com.es/2012/03//failback-monad.html>)
-
-
-[@Cached widgets@] with `cachedWidget` it is possible to cache the rendering of a widget as a ByteString (maintaining type safety)
-, the caching can be permanent or for a certain time. this is very useful for complex widgets that present information. Specially if
-the widget content comes from a database and it is shared by all users.
-
-
-[@Callbacks@] `waction` add a callback to a widget. It is executed when its input is validated.
-The callback may initate a flow of interactions with the user or simply executes an internal computation.
-Callbacks are necessary for the creation of abstract container
-widgets that may not know the behaviour of its content. with callbacks, the widget manages its content as black boxes.
-
-
-[@Modifiers@] `wmodify` change the visualization and result returned by the widget. For example it may hide a
-login form and substitute it by the username if already logged.
-
-Example:
-
-@ ask $ wform userloginform \``validate`\` valdateProc \``waction`\` loginProc \``wmodify`\` hideIfLogged@
-
-
-[@attributes for formLet elements@] to add atributes to widgets. See the '<!' opèrator
-
-
-[@ByteString normalization and hetereogeneous formatting@] For caching the rendering of widgets at the
- ByteString level, and to permit many formatring styles
-in the same page, there are operators that combine different formats which are converted to ByteStrings.
-For example the header and footer may be coded in XML, while the formlets may be formatted using Text.XHtml.
-
-[@File Server@] With file caching. See "MFlow.FileServer"
-
-
--}
-
-module MFlow.Forms(
-
--- * Basic definitions
--- FormLet(..),
-FlowM, View(..), FormElm(..), FormInput(..)
-
--- * Users
-, Auth(..), userRegister, setAuthMethod, userValidate, isLogged, setAdminUser, getAdminName
-,getCurrentUser,getUserSimple, getUser, userFormLine, userLogin,logout, paranoidLogout
-,encryptedLogout, userWidget, paranoidUserWidget, encryptedUserWidget, login, paranoidLogin, encryptedLogin,
-userName,
--- * User interaction
-ask, page, askt, clearEnv, wstateless, pageFlow,
--- * formLets
--- | They usually produce the HTML form elements (depending on the FormInput instance used)
--- It is possible to modify their attributes with the `<!` operator.
--- They are combined with applicative ombinators and some additional ones
--- formatting can be added with the formatting combinators.
--- modifiers change their presentation and behaviour
-getString,getInt,getInteger, getTextBox
-,getMultilineText,getBool,getSelect, setOption,setSelectedOption, getPassword,
-getRadio, setRadio, setRadioActive, wlabel, getCheckBoxes, genCheckBoxes, setCheckBox,
-submitButton,resetButton, whidden, wlink, absLink, getKeyValueParam,
+{-# OPTIONS -XDeriveDataTypeable
+ -XUndecidableInstances
+ -XExistentialQuantification
+ -XMultiParamTypeClasses
+ -XTypeSynonymInstances
+ -XFlexibleInstances
+ -XScopedTypeVariables
+ -XFunctionalDependencies
+ -XFlexibleContexts
+ -XRecordWildCards
+ -XIncoherentInstances
+ -XTypeFamilies
+ -XTypeOperators
+ -XOverloadedStrings
+ -XTemplateHaskell
+ -XNoMonomorphismRestriction
+
+#-}
+
+{- |
+MFlow run stateful server processes. This version is the first stateful web framework
+that is as RESTful as a web framework can be.
+
+The routes are expressed as normal, monadic haskell code in the FlowM monad. Local links
+point to alternative routes within this monadic computation just like a textual menu
+in a console application. Any GET page is directly reachable by means of a RESTful URL.
+
+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.
+If the procedure is waiting for another different page, the FlowM monad backtrack until the path partially match
+. From this position the execution goes forward until the rest of the path match. This way the
+statelessness is optional. However, it is possible to store a session state, which may backtrack or
+not when the navigation goes back and forth. It is upto the programmer.
+
+
+All the flow of requests and responses are coded by the programmer in a single procedure.
+Allthoug single request-response flows are possible. Therefore, the code is
+more understandable. It is not continuation based. It uses a log for thread state persistence and backtracking for
+handling the back button. Back button state syncronization is supported out-of-the-box
+
+The MFlow architecture is scalable, since the state is serializable and small
+
+The processes are stopped and restarted by the
+application server on demand, including the execution state (if the Wokflow monad is used).
+Therefore session management is automatic. State consistence and transactions are given by the TCache package.
+
+The processes interact trough widgets, that are an extension of formlets with
+additional applicative combinators, formatting, link management, callbacks, modifiers, caching,
+byteString conversion and AJAX. All is coded in pure haskell.
+
+The interfaces and communications are abstract, but there are bindings for blaze-html, HSP, Text.XHtml and byteString
+, Hack and WAI but it can be extended to non Web based architectures.
+
+Bindings for hack, and hsp >= 0.8, are not compiled by Hackage, and do not appear, but are included in the package files.
+To use them, add then to the exported modules and execute cabal install
+
+It is designed for applications that can be run with no deployment with runghc in order
+to speed up the development process. see <http://haskell-web.blogspot.com.es/2013/05/a-web-application-in-tweet.html>
+
+This module implement stateful processes (flows) that are optionally persistent.
+This means that they automatically store and recover his execution state. They are executed by the MFlow app server.
+defined in the "MFlow" module.
+
+These processses interact with the user trough user interfaces made of widgets (see below) that return back statically typed responses to
+the calling process. Because flows are stateful, not request-response, the code is more understandable, because
+all the flow of request and responses is coded by the programmer in a single procedure in the FlowM monad. Allthoug
+single request-response flows and callbacks are possible.
+
+This module is abstract with respect to the formatting (here referred with the type variable @view@) . For an
+instantiation for "Text.XHtml" import "MFlow.Forms.XHtml", "MFlow.Hack.XHtml.All" or "MFlow.Wai.XHtml.All" .
+To use Haskell Server Pages import "MFlow.Forms.HSP". However the functionalities are documented here.
+
+`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.
+It send user interfaces (in the @View view m@ monad) and return statically
+typed responses. The user interface definitions are based on a extension of
+formLets (<http://www.haskell.org/haskellwiki/Formlets>) with the addition of caching, links, formatting, attributes,
+ extra combinators, callbaks and modifiers.
+The interaction with the user is stateful. In the same computation there may be many
+request-response interactions, in the same way than in the case of a console applications.
+
+* APPLICATION SERVER
+
+Therefore, session and state management is simple and transparent: it is in the haskell
+structures in the scope of the computation. `transient` (normal) procedures have no persistent session state
+and `stateless` procedures accept a single request and return a single response.
+
+`MFlow.Forms.step` is a lifting monad transformer that permit persistent server procedures that
+remember the execution state even after system shutdowns by using the package workflow (<http://hackage.haskell.org/package/Workflow>) internally.
+This state management is transparent. There is no programer interface for session management.
+
+The programmer set the process timeout and the session timeout with `setTimeouts`.
+If the procedure has been stopped due to the process timeout or due to a system shutdowm,
+the procedure restart in the last state when a request for this procedure arrives
+(if the procedure uses the `step` monad transformer)
+
+* WIDGETS
+
+The correctness of the web responses is assured by the use of formLets.
+But unlike formLets in its current form, it permits the definition of widgets.
+/A widget is a combination of formLets and links within its own formatting template/, all in
+the same definition in the same source file, in plain declarative Haskell style.
+
+The formatting is abstract. It has to implement the 'FormInput' class.
+There are instances for Text.XHtml ("MFlow.Forms.XHtml"), Haskell Server Pages ("MFlow.Forms.HSP")
+and ByteString. So widgets
+can use any formatting that is instance of `FormInput`.
+It is possible to use more than one format in the same widget.
+
+Links defined with `wlink` are treated the same way than forms. They are type safe and return values
+ to the same flow of execution.
+It is posssible to combine links and forms in the same widget by using applicative combinators but also
+additional applicative combinators like \<+> !*> , |*|. Widgets are also monoids, so they can
+be combined as such.
+
+* NEW IN THIS RELEASE
+
+[@Runtime templates@] 'template', 'edTemplate', 'witerate' and 'dField' permit the edition of
+the widget content at runtime, and the management of placeholders with input fields and data fields
+within the template with no navigation in the client, little bandwidth usage and little server load. Enven less
+than using 'autoRefresh'.
+
+* IN PREVIOUS RELEASES
+
+{@AutoRefresh@] Using `autoRefresh`, Dynamic widgets can refresh themselves with new information without forcing a refresh of the whole page
+
+[@Push@] With `push` a widget can push new content to the browser when something in the server happens
+
+[@Error traces@] using the monadloc package, now each runtime error (in a monadic statement) has a complete execution trace.
+
+
+[@RESTful URLs@] Now each page is directly reachable by means of a intuitive, RESTful url, whose path is composed by the sucession
+of links clicked to reach such page and such point in the procedure. Just what you would expect.
+
+[@Page flows@] each widget-formlet can have its own independent behaviour within the page. They can
+refresh independently trough AJAX by means of 'autoRefresh'. Additionally, 'pageFlow' initiates the page flow mode or a
+subpage flow by adding a well know indetifier prefix for links and form parameters.
+
+[@Modal Dialogs@] 'wdialog' present a widget within a modal or non modal jQuery dialog. while a monadic
+widget-formlet can add different form elements depending on the user responses, 'wcallback' can
+substitute the widget by other. (See 'Demos/demos.blaze.hs' for some examples)
+
+[@JQuery widgets@] with MFlow interface: 'getSpinner', 'datePicker', 'wdialog'
+
+[@WAI interface@] Now MFlow works with Snap and other WAI developments. Include "MFlow.Wai" or "MFlow.Wai.Blaze.Html.All" to use it.
+
+[@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
+
+[@AJAX@] Now an ajax procedures (defined with 'ajax' can perform many interactions with the browser widgets, instead
+of a single request-response (see 'ajaxSend').
+
+[@Active widgets@] "MFlow.Forms.Widgets" contains active widgets that interact with the
+server via Ajax and dynamically control other widgets: 'wEditList', 'autocomplete' 'autocompleteEdit' and others.
+
+[@Requirements@] a widget can specify javaScript files, JavasScript online scipts, CSS files, online CSS and server processes
+ and any other instance of the 'Requrement' class. See 'requires' and 'WebRequirements'
+
+[@content-management@] for templating and online edition of the content template. See 'tFieldEd' 'tFieldGen' and 'tField'
+
+[@multilanguage@] see 'mField' and 'mFieldEd'
+
+[@URLs to internal states@] if the web navigation is trough GET forms or links,
+ an URL can express a direct path to the n-th step of a flow, So this URL can be shared with other users.
+Just like in the case of an ordinary stateless application.
+
+
+[@Back Button@] This is probably the first implementation in any language where the navigation
+can be expressed procedurally and still it works well with the back button, thanks
+to monad magic. (See <http://haskell-web.blogspot.com.es/2012/03//failback-monad.html>)
+
+
+[@Cached widgets@] with `cachedWidget` it is possible to cache the rendering of a widget as a ByteString (maintaining type safety)
+, the caching can be permanent or for a certain time. this is very useful for complex widgets that present information. Specially if
+the widget content comes from a database and it is shared by all users.
+
+
+[@Callbacks@] `waction` add a callback to a widget. It is executed when its input is validated.
+The callback may initate a flow of interactions with the user or simply executes an internal computation.
+Callbacks are necessary for the creation of abstract container
+widgets that may not know the behaviour of its content. with callbacks, the widget manages its content as black boxes.
+
+
+[@Modifiers@] `wmodify` change the visualization and result returned by the widget. For example it may hide a
+login form and substitute it by the username if already logged.
+
+Example:
+
+@ ask $ wform userloginform \``validate`\` valdateProc \``waction`\` loginProc \``wmodify`\` hideIfLogged@
+
+
+[@attributes for formLet elements@] to add atributes to widgets. See the '<!' opèrator
+
+
+[@ByteString normalization and hetereogeneous formatting@] For caching the rendering of widgets at the
+ ByteString level, and to permit many formatring styles
+in the same page, there are operators that combine different formats which are converted to ByteStrings.
+For example the header and footer may be coded in XML, while the formlets may be formatted using Text.XHtml.
+
+[@File Server@] With file caching. See "MFlow.FileServer"
+
+
+-}
+
+module MFlow.Forms(
+
+-- * Basic definitions
+-- FormLet(..),
+FlowM, View(..), FormElm(..), FormInput(..)
+
+-- * Users
+, Auth(..), userRegister, setAuthMethod, userValidate, isLogged, setAdminUser, getAdminName
+,getCurrentUser,getUserSimple, getUser, userFormLine, userLogin,logout, paranoidLogout
+,encryptedLogout, userWidget, paranoidUserWidget, encryptedUserWidget, login, paranoidLogin, encryptedLogin,
+userName,
+-- * User interaction
+ask, page, askt, clearEnv, wstateless, pageFlow,
+-- * formLets
+-- | They usually produce the HTML form elements (depending on the FormInput instance used)
+-- It is possible to modify their attributes with the `<!` operator.
+-- They are combined with applicative ombinators and some additional ones
+-- formatting can be added with the formatting combinators.
+-- modifiers change their presentation and behaviour
+getString,getInt,getInteger, getTextBox
+,getMultilineText,getBool,getSelect, setOption,setSelectedOption, getPassword,
+getRadio, setRadio, setRadioActive, wlabel, getCheckBoxes, genCheckBoxes, setCheckBox,
+submitButton,resetButton, whidden, wlink, absLink, getKeyValueParam, fileUpload,
getRestParam, returning, wform, firstOf, manyOf, allOf, wraw, wrender, notValid
--- * FormLet modifiers
-,validate, noWidget, stop, waction, wcallback, wmodify,
-
--- * Caching widgets
-cachedWidget, wcached, wfreeze,
-
--- * Widget combinators
-(<+>),(|*>),(|+|), (**>),(<**),(<|>),(<*),(<$>),(<*>),(>:>)
-
----- * Normalized (convert to ByteString) widget combinators
----- | These dot operators are indentical to the non dot operators, with the addition of the conversion of the arguments to lazy byteStrings
-----
----- The purpose is to combine heterogeneous formats into byteString-formatted widgets that
----- can be cached with `cachedWidget`
---,(.<+>.), (.|*>.), (.|+|.), (.**>.),(.<**.), (.<|>.),
-
--- * Formatting combinators
-,(<<<),(++>),(<++),(<!)
-
----- * Normalized (convert to ByteString) formatting combinators
----- | Some combinators that convert the formatting of their arguments to lazy byteString
-----(.<<.),(.<++.),(.++>.)
-
--- * ByteString tags
-,btag,bhtml,bbody
-
--- * Normalization
-,flatten, normalize
-
--- * Running the flow monad
-,runFlow, transientNav, runFlowOnce, runFlowIn
-,runFlowConf,MFlow.Forms.Internals.step
--- * controlling backtracking
-,goingBack,returnIfForward, breturn, preventGoingBack, compensate, onBacktrack, retry
-
+-- * FormLet modifiers
+,validate, noWidget, stop, waction, wcallback, wmodify,
+
+-- * Caching widgets
+cachedWidget, wcached, wfreeze,
+
+-- * Widget combinators
+(<+>),(|*>),(|+|), (**>),(<**),(<|>),(<*),(<$>),(<*>),(>:>)
+
+---- * Normalized (convert to ByteString) widget combinators
+---- | These dot operators are indentical to the non dot operators, with the addition of the conversion of the arguments to lazy byteStrings
+----
+---- The purpose is to combine heterogeneous formats into byteString-formatted widgets that
+---- can be cached with `cachedWidget`
+--,(.<+>.), (.|*>.), (.|+|.), (.**>.),(.<**.), (.<|>.),
+
+-- * Formatting combinators
+,(<<<),(++>),(<++),(<!)
+
+---- * Normalized (convert to ByteString) formatting combinators
+---- | Some combinators that convert the formatting of their arguments to lazy byteString
+----(.<<.),(.<++.),(.++>.)
+
+-- * ByteString tags
+,btag,bhtml,bbody
+
+-- * Normalization
+,flatten, normalize
+
+-- * Running the flow monad
+,runFlow, transientNav, runFlowOnce, runFlowIn
+,runFlowConf,MFlow.Forms.Internals.step
+-- * controlling backtracking
+,goingBack,returnIfForward, breturn, preventGoingBack, compensate, onBacktrack, retry
+
-- * Setting parameters
-,setHttpHeader
-,setHeader
-,addHeader
-,getHeader
-,setSessionData
+,setHttpHeader
+,setHeader
+,addHeader
+,getHeader
+,setSessionData
,getSessionData
-,getSData
-,delSessionData
-,setTimeouts
-
--- * Cookies
-,setCookie
-,setParanoidCookie
-,setEncryptedCookie
--- * Ajax
-,ajax
-,ajaxSend
-,ajaxSend_
--- * Requirements
-,Requirements(..)
-,WebRequirement(..)
-,requires
+,getSData
+,delSessionData
+,setTimeouts
+
+-- * Cookies
+,setCookie
+,setParanoidCookie
+,setEncryptedCookie
+-- * Ajax
+,ajax
+,ajaxSend
+,ajaxSend_
+-- * Requirements
+,Requirements(..)
+,WebRequirement(..)
+,requires
-- * Utility
-,getSessionId
-,getLang
-,genNewId
-,getNextId
-,changeMonad
-,FailBack
-,fromFailBack
-,toFailBack
-
-)
-where
-
-import Data.RefSerialize hiding ((<|>),empty)
-import Data.TCache
-import Data.TCache.Memoization
-import MFlow
-import MFlow.Forms.Internals
-import MFlow.Cookies
+,getSessionId
+,getLang
+,genNewId
+,getNextId
+,changeMonad
+,FailBack
+,fromFailBack
+,toFailBack
+
+)
+where
+
+import Data.RefSerialize hiding ((<|>),empty)
+import Data.TCache
+import Data.TCache.Memoization
+import MFlow
+import MFlow.Forms.Internals
+import MFlow.Cookies
import Data.ByteString.Lazy.Char8 as B(ByteString,cons,append,empty,fromChunks,unpack)
import Data.ByteString.Lazy.UTF8 hiding (length, take)
-import qualified Data.String as S
-import qualified Data.Text as T
-import Data.Text.Encoding
-import Data.List
---import qualified Data.CaseInsensitive as CI
-import Data.Typeable
-import Data.Monoid
-import Control.Monad.State.Strict
-import Data.Maybe
-import Control.Applicative
-import Control.Exception
-import Control.Concurrent
-import Control.Workflow as WF
-import Control.Monad.Identity
-import Unsafe.Coerce
-import Data.List(intersperse)
-import Data.IORef
-import qualified Data.Map as M
-import System.IO.Unsafe
-import Data.Char(isNumber,toLower)
-import Network.HTTP.Types.Header
-import MFlow.Forms.Cache
-
--- | Validates a form or widget result against a validating procedure
---
--- @getOdd= getInt Nothing `validate` (\x -> return $ if mod x 2==0 then Nothing else Just "only odd numbers, please")@
-validate
- :: (FormInput view, Monad m) =>
- View view m a
- -> (a -> WState view m (Maybe view))
- -> View view m a
-validate formt val= View $ do
- FormElm form mx <- runView formt
- case mx of
- Just x -> do
- me <- val x
- modify (\s -> s{inSync= True})
- case me of
- Just str ->
- return $ FormElm ( form <> inred str) Nothing
- Nothing -> return $ FormElm form mx
- _ -> return $ FormElm form mx
-
--- | Actions are callbacks that are executed when a widget is validated.
--- A action may be a complete flow in the flowM monad. It takes complete control of the navigation
--- while it is executed. At the end it return the result to the caller and display the original
--- calling page.
--- It is useful when the widget is inside widget containers that may treat it as a black box.
---
--- It returns a result that can be significative or, else, be ignored with '<**' and '**>'.
--- An action may or may not initiate his own dialog with the user via `ask`
-waction
- :: (FormInput view, Monad m)
- => View view m a
- -> (a -> FlowM view m b)
- -> View view m b
-waction f ac = do
- x <- f
- s <- get
- let env = mfEnv s
- let seq = mfSequence s
- put s{mfSequence=mfSequence s+ 100,mfEnv=[],newAsk=True}
- r <- flowToView $ ac x
- modify $ \s-> s{mfSequence= seq, mfEnv= env}
- return r
- where
- flowToView x=
- View $ do
- r <- runSup $ runFlowM x
- case r of
- NoBack x ->
- return (FormElm mempty $ Just x)
- BackPoint x->
- return (FormElm mempty $ Just x)
- GoBack-> do
- modify $ \s ->s{notSyncInAction= True}
- return (FormElm mempty Nothing)
-
--- | change the rendering and the return value of a page. This is superseeded by page flows.
-wmodify :: (Monad m, FormInput v)
- => View v m a
- -> (v -> Maybe a -> WState v m (v, Maybe b))
- -> View v m b
-wmodify formt act = View $ do
- FormElm f mx <- runView formt
- (f',mx') <- act f mx
- return $ FormElm f' mx'
-
--- | Display a text box and return a non empty String
-getString :: (FormInput view,Monad m) =>
- Maybe String -> View view m String
-getString ms = getTextBox ms
- `validate`
- \s -> if null s then return (Just $ fromStr "")
- else return Nothing
-
--- | Display a text box and return an Integer (if the value entered is not an Integer, fails the validation)
-getInteger :: (FormInput view, MonadIO m) =>
- Maybe Integer -> View view m Integer
-getInteger = getTextBox
-
--- | Display a text box and return a Int (if the value entered is not an Int, fails the validation)
-getInt :: (FormInput view, MonadIO m) =>
- Maybe Int -> View view m Int
-getInt = getTextBox
-
--- | Display a password box
-getPassword :: (FormInput view,
- Monad m) =>
- View view m String
-getPassword = getParam Nothing "password" Nothing
-
-newtype Radio a= Radio a
-
--- | Implement a radio button that perform a submit when pressed.
--- the parameter is the name of the radio group
-setRadioActive :: (FormInput view, MonadIO m,
- Read a, Typeable a, Eq a, Show a) =>
- a -> String -> View view m (Radio a)
-setRadioActive v n = View $ do
- st <- get
- put st{needForm= HasElems}
- let env = mfEnv st
- mn <- getParam1 n env
- let str = if typeOf v == typeOf(undefined :: String)
- then unsafeCoerce v else show v
- return $ FormElm (finput n "radio" str
- ( isValidated mn && v== fromValidated mn) (Just "this.form.submit()"))
- (fmap Radio $ valToMaybe mn)
-
-
--- | Implement a radio button
--- the parameter is the name of the radio group
-setRadio :: (FormInput view, MonadIO m,
- Read a, Typeable a, Eq a, Show a) =>
- a -> String -> View view m (Radio a)
-setRadio v n= View $ do
- st <- get
- put st{needForm= HasElems}
- let env = mfEnv st
- mn <- getParam1 n env
- let str = if typeOf v == typeOf(undefined :: String)
- then unsafeCoerce v else show v
- return $ FormElm (finput n "radio" str
- ( isValidated mn && v== fromValidated mn) Nothing)
- (fmap Radio $ valToMaybe mn)
-
--- | encloses a set of Radio boxes. Return the option selected
-getRadio
- :: (Monad m, Functor m, FormInput view) =>
- [String -> View view m (Radio a)] -> View view m a
-getRadio rs= do
- id <- genNewId
- Radio r <- firstOf $ map (\r -> r id) rs
- return r
-
-data CheckBoxes = CheckBoxes [String]
-
-instance Monoid CheckBoxes where
- mappend (CheckBoxes xs) (CheckBoxes ys)= CheckBoxes $ xs ++ ys
- mempty= CheckBoxes []
-
---instance (Monad m, Functor m) => Monoid (View v m CheckBoxes) where
--- mappend x y= mappend <$> x <*> y
--- mempty= return (CheckBoxes [])
-
-
--- | Display a text box and return the value entered if it is readable( Otherwise, fail the validation)
-setCheckBox :: (FormInput view, MonadIO m) =>
- Bool -> String -> View view m CheckBoxes
-setCheckBox checked v= View $ do
- n <- genNewId
- st <- get
- put st{needForm= HasElems}
- let env = mfEnv st
- strs= map snd $ filter ((==) n . fst) env
- mn= if null strs then Nothing else Just $ head strs
- val = inSync st
- let ret= case val of -- !> show val of
- True -> Just $ CheckBoxes strs -- !> show strs
- False -> Nothing
- return $ FormElm
- ( finput n "checkbox" v
- ( checked || (isJust mn && v== fromJust mn)) Nothing)
- ret
-
--- | Read the checkboxes dinamically created by JavaScript within the view parameter
--- see for example `selectAutocomplete` in "MFlow.Forms.Widgets"
-genCheckBoxes :: (Monad m, FormInput view) => view -> View view m CheckBoxes
-genCheckBoxes v= View $ do
- n <- genNewId
- st <- get
- put st{needForm= HasElems}
- let env = mfEnv st
- strs= map snd $ filter ((==) n . fst) env
- mn= if null strs then Nothing else Just $ head strs
-
- val <- gets inSync
- let ret= case val of
- True -> Just $ CheckBoxes strs
- False -> Nothing
- return $ FormElm (ftag "span" v `attrs`[("id",n)]) ret
-
-whidden :: (Monad m, FormInput v,Read a, Show a, Typeable a) => a -> View v m a
-whidden x= View $ do
- n <- genNewId
- env <- gets mfEnv
- let showx= case cast x of
- Just x' -> x'
- Nothing -> show x
- r <- getParam1 n env
- return . FormElm (finput n "hidden" showx False Nothing) $ valToMaybe r
-
-getCheckBoxes :: (FormInput view, Monad m)=> View view m CheckBoxes -> View view m [String]
-getCheckBoxes boxes = View $ do
- n <- genNewId
- st <- get
- let env = mfEnv st
- let form= finput n "hidden" "" False Nothing
- mr <- getParam1 n env
-
- let env = mfEnv st
- modify $ \st -> st{needForm= HasElems}
- FormElm form2 mr2 <- runView boxes
- return $ FormElm (form <> form2) $
- case (mr `asTypeOf` Validated ("" :: String),mr2) of
- (NoParam,_) -> Nothing
- (Validated _,Nothing) -> Just []
- (Validated _, Just (CheckBoxes rs)) -> Just rs
-
-
-
-
-
-getTextBox
- :: (FormInput view,
- Monad m,
- Typeable a,
- Show a,
- Read a) =>
- Maybe a -> View view m a
-getTextBox ms = getParam Nothing "text" ms
-
-
-getParam
- :: (FormInput view,
- Monad m,
- Typeable a,
- Show a,
- Read a) =>
- Maybe String -> String -> Maybe a -> View view m a
-getParam look type1 mvalue = View $ do
- tolook <- case look of
- Nothing -> genNewId
- Just n -> return n
- let nvalue x = case x of
- Nothing -> ""
- Just v ->
- case cast v of
- Just v' -> v'
- Nothing -> show v
- st <- get
- let env = mfEnv st
- put st{needForm= HasElems}
- r <- getParam1 tolook env
- case r of
- Validated x -> return $ FormElm (finput tolook type1 (nvalue $ Just x) False Nothing) $ Just x
- NotValidated s err -> return $ FormElm (finput tolook type1 s False Nothing <> err) $ Nothing
- NoParam -> return $ FormElm (finput tolook type1 (nvalue mvalue) False Nothing) $ Nothing
-
-
-
---getCurrentName :: MonadState (MFlowState view) m => m String
---getCurrentName= do
--- st <- get
--- let parm = mfSequence st
--- return $ "p"++show parm
-
-
--- | Display a multiline text box and return its content
-getMultilineText :: (FormInput view
- , Monad m)
- => T.Text
- -> View view m T.Text
-getMultilineText nvalue = View $ do
- tolook <- genNewId
- env <- gets mfEnv
- r <- getParam1 tolook env
- case r of
- Validated x -> return $ FormElm (ftextarea tolook x) $ Just x
- NotValidated s err -> return $ FormElm (ftextarea tolook (T.pack s)) Nothing
- NoParam -> return $ FormElm (ftextarea tolook nvalue) Nothing
-
-
---instance (MonadIO m, Functor m, FormInput view) => FormLet Bool m view where
--- digest mv = getBool b "True" "False"
--- where
--- b= case mv of
--- Nothing -> Nothing
--- Just bool -> Just $ case bool of
--- True -> "True"
--- False -> "False"
-
--- | Display a dropdown box with the two values (second (true) and third parameter(false))
--- . With the value of the first parameter selected.
-getBool :: (FormInput view,
- Monad m, Functor m) =>
- Bool -> String -> String -> View view m Bool
-getBool mv truestr falsestr= do
- r <- getSelect $ setOption truestr (fromStr truestr) <! (if mv then [("selected","true")] else [])
- <|> setOption falsestr(fromStr falsestr) <! if not mv then [("selected","true")] else []
- if r == truestr then return True else return False
-
-
-
--- | Display a dropdown box with the options in the first parameter is optionally selected
--- . It returns the selected option.
-getSelect :: (FormInput view,
- Monad m,Typeable a, Read a) =>
- View view m (MFOption a) -> View view m a
-getSelect opts = View $ do
- tolook <- genNewId
- st <- get
- let env = mfEnv st
- put st{needForm= HasElems}
- r <- getParam1 tolook env
- setSessionData $ fmap MFOption $ valToMaybe r
- FormElm form mr <- (runView opts)
-
- return $ FormElm (fselect tolook form) $ valToMaybe r
-
-
-newtype MFOption a= MFOption a deriving Typeable
-
-instance (FormInput view,Monad m, Functor m) => Monoid (View view m (MFOption a)) where
- mappend = (<|>)
- mempty = Control.Applicative.empty
-
--- | Set the option for getSelect. Options are concatenated with `<|>`
-setOption
- :: (Monad m, Show a, Eq a, Typeable a, FormInput view) =>
- a -> view -> View view m (MFOption a)
-setOption n v = do
- mo <- getSessionData
- case mo of
- Nothing -> setOption1 n v False
- Just Nothing -> setOption1 n v False
- Just (Just (MFOption o)) -> setOption1 n v $ n == o
-
--- | Set the selected option for getSelect. Options are concatenated with `<|>`
-setSelectedOption
- :: (Monad m, Show a, Eq a, Typeable a, FormInput view) =>
- a -> view -> View view m (MFOption a)
-setSelectedOption n v= do
- mo <- getSessionData
- case mo of
- Nothing -> setOption1 n v True
- Just Nothing -> setOption1 n v True
- Just (Just o) -> setOption1 n v $ n == o
-
-
-setOption1 :: (FormInput view,
- Monad m, Typeable a, Eq a, Show a) =>
- a -> view -> Bool -> View view m (MFOption a)
-setOption1 nam val check= View $ do
- st <- get
- let env = mfEnv st
- put st{needForm= HasElems}
- let n = if typeOf nam == typeOf(undefined :: String)
- then unsafeCoerce nam
- else show nam
-
- return . FormElm (foption n val check) . Just $ MFOption nam
-
---fileUpload :: (FormInput view,
--- Monad m) =>
--- View view m T.Text
---fileUpload= getParam Nothing "file" Nothing
-
-
--- | Enclose Widgets within some formating.
--- @view@ is intended to be instantiated to a particular format
---
--- NOTE: It has a infix priority : @infixr 5@ less than the one of @++>@ and @<++@ of the operators, so use parentheses when appropriate,
--- unless the we want to enclose all the widgets in the right side.
--- Most of the type errors in the DSL are due to the low priority of this operator.
---
--- This is a widget, which is a table with some links. it returns an Int
---
--- > import MFlow.Forms.Blaze.Html
--- >
--- > tableLinks :: View Html Int
--- > table ! At.style "border:1;width:20%;margin-left:auto;margin-right:auto"
--- > <<< caption << text "choose an item"
--- > ++> thead << tr << ( th << b << text "item" <> th << b << text "times chosen")
--- > ++> (tbody
--- > <<< tr ! rowspan "2" << td << linkHome
--- > ++> (tr <<< td <<< wlink IPhone (b << text "iphone") <++ td << ( b << text (fromString $ show ( cart V.! 0)))
--- > <|> tr <<< td <<< wlink IPod (b << text "ipad") <++ td << ( b << text (fromString $ show ( cart V.! 1)))
--- > <|> tr <<< td <<< wlink IPad (b << text "ipod") <++ td << ( b << text (fromString $ show ( cart V.! 2))))
--- > )
-(<<<) :: (Monad m, Monoid view)
- => (view ->view)
- -> View view m a
- -> View view m a
-(<<<) v form= View $ do
- FormElm f mx <- runView form
- return $ FormElm (v f) mx
-
-
-infixr 5 <<<
-
-
-
-
-
-
--- | Append formatting code to a widget
---
--- @ getString "hi" <++ H1 << "hi there"@
---
--- It has a infix prority: @infixr 6@ higuer that '<<<' and most other operators
-(<++) :: (Monad m, Monoid v)
- => View v m a
- -> v
- -> View v m a
-(<++) form v= View $ do
- FormElm f mx <- runView form
- return $ FormElm ( f <> v) mx
-
-infixr 6 ++>
-infixr 6 <++
--- | Prepend formatting code to a widget
---
--- @bold << "enter name" ++> getString Nothing @
---
--- It has a infix prority: @infixr 6@ higuer that '<<<' and most other operators
-(++>) :: (Monad m, Monoid view)
- => view -> View view m a -> View view m a
-html ++> w = -- (html <>) <<< digest
- View $ do
- FormElm f mx <- runView w
- return $ FormElm (html <> f) mx
-
-
-
--- | Add attributes to the topmost tag of a widget
---
--- it has a fixity @infix 8@
-infixl 8 <!
-widget <! attribs= View $ do
- FormElm fs mx <- runView widget
- return $ FormElm (fs `attrs` attribs) mx -- (head fs `attrs` attribs:tail fs) mx
--- case fs of
--- [hfs] -> return $ FormElm [hfs `attrs` attribs] mx
--- _ -> error $ "operator <! : malformed widget: "++ concatMap (unpack. toByteString) fs
-
-
--- | Is an example of login\/register validation form needed by 'userWidget'. In this case
--- the form field appears in a single line. it shows, in sequence, entries for the username,
--- password, a button for loging, a entry to repeat password necesary for registering
--- and a button for registering.
--- The user can build its own user login\/validation forms by modifying this example
---
--- @ userFormLine=
--- (User \<\$\> getString (Just \"enter user\") \<\*\> getPassword \<\+\> submitButton \"login\")
--- \<\+\> fromStr \" password again\" \+\> getPassword \<\* submitButton \"register\"
--- @
-userFormLine :: (FormInput view, Functor m, Monad m)
- => View view m (Maybe (UserStr,PasswdStr), Maybe PasswdStr)
-userFormLine=
- ((,) <$> getString (Just "enter user") <! [("size","5")]
- <*> getPassword <! [("size","5")]
- <** submitButton "login")
- <+> (fromStr " password again" ++> getPassword <! [("size","5")]
- <** submitButton "register")
-
--- | Example of user\/password form (no validation) to be used with 'userWidget'
-userLogin :: (FormInput view, Functor m, Monad m)
- => View view m (Maybe (UserStr,PasswdStr), Maybe String)
-userLogin=
- ((,) <$> fromStr "Enter User: " ++> getString Nothing <! [("size","4")]
- <*> fromStr " Enter Pass: " ++> getPassword <! [("size","4")]
- <** submitButton "login")
- <+> (noWidget
- <* noWidget)
-
-
-
--- | Empty widget that does not validate. May be used as \"empty boxes\" inside larger widgets.
---
--- It returns a non valid value.
-noWidget :: (FormInput view,
- Monad m, Functor m) =>
- View view m a
-noWidget= Control.Applicative.empty
+import qualified Data.String as S
+import qualified Data.Text as T
+import Data.Text.Encoding
+import Data.List
+--import qualified Data.CaseInsensitive as CI
+import Data.Typeable
+import Data.Monoid
+import Control.Monad.State.Strict
+import Data.Maybe
+import Control.Applicative
+import Control.Exception
+import Control.Concurrent
+import Control.Workflow as WF
+import Control.Monad.Identity
+import Unsafe.Coerce
+import Data.List(intersperse)
+import Data.IORef
+import qualified Data.Map as M
+import System.IO.Unsafe
+import Data.Char(isNumber,toLower)
+import Network.HTTP.Types.Header
+import MFlow.Forms.Cache
+
+-- | Validates a form or widget result against a validating procedure
+--
+-- @getOdd= getInt Nothing `validate` (\x -> return $ if mod x 2==0 then Nothing else Just "only odd numbers, please")@
+validate
+ :: (FormInput view, Monad m) =>
+ View view m a
+ -> (a -> WState view m (Maybe view))
+ -> View view m a
+validate formt val= View $ do
+ FormElm form mx <- runView formt
+ case mx of
+ Just x -> do
+ me <- val x
+ modify (\s -> s{inSync= True})
+ case me of
+ Just str ->
+ return $ FormElm ( form <> inred str) Nothing
+ Nothing -> return $ FormElm form mx
+ _ -> return $ FormElm form mx
+
+-- | Actions are callbacks that are executed when a widget is validated.
+-- A action may be a complete flow in the flowM monad. It takes complete control of the navigation
+-- while it is executed. At the end it return the result to the caller and display the original
+-- calling page.
+-- It is useful when the widget is inside widget containers that may treat it as a black box.
+--
+-- It returns a result that can be significative or, else, be ignored with '<**' and '**>'.
+-- An action may or may not initiate his own dialog with the user via `ask`
+waction
+ :: (FormInput view, Monad m)
+ => View view m a
+ -> (a -> FlowM view m b)
+ -> View view m b
+waction f ac = do
+ x <- f
+ s <- get
+ let env = mfEnv s
+ let seq = mfSequence s
+ put s{mfSequence=mfSequence s+ 100,mfEnv=[],newAsk=True}
+ r <- flowToView $ ac x
+ modify $ \s-> s{mfSequence= seq, mfEnv= env}
+ return r
+ where
+ flowToView x=
+ View $ do
+ r <- runSup $ runFlowM x
+ case r of
+ NoBack x ->
+ return (FormElm mempty $ Just x)
+ BackPoint x->
+ return (FormElm mempty $ Just x)
+ GoBack-> do
+ modify $ \s ->s{notSyncInAction= True}
+ return (FormElm mempty Nothing)
+
+-- | change the rendering and the return value of a page. This is superseeded by page flows.
+wmodify :: (Monad m, FormInput v)
+ => View v m a
+ -> (v -> Maybe a -> WState v m (v, Maybe b))
+ -> View v m b
+wmodify formt act = View $ do
+ FormElm f mx <- runView formt
+ (f',mx') <- act f mx
+ return $ FormElm f' mx'
+
+-- | Display a text box and return a non empty String
+getString :: (FormInput view,Monad m) =>
+ Maybe String -> View view m String
+getString ms = getTextBox ms
+ `validate`
+ \s -> if null s then return (Just $ fromStr "")
+ else return Nothing
+
+-- | Display a text box and return an Integer (if the value entered is not an Integer, fails the validation)
+getInteger :: (FormInput view, MonadIO m) =>
+ Maybe Integer -> View view m Integer
+getInteger = getTextBox
+
+-- | Display a text box and return a Int (if the value entered is not an Int, fails the validation)
+getInt :: (FormInput view, MonadIO m) =>
+ Maybe Int -> View view m Int
+getInt = getTextBox
+
+-- | Display a password box
+getPassword :: (FormInput view,
+ Monad m) =>
+ View view m String
+getPassword = getParam Nothing "password" Nothing
+
+newtype Radio a= Radio a
+
+-- | Implement a radio button that perform a submit when pressed.
+-- the parameter is the name of the radio group
+setRadioActive :: (FormInput view, MonadIO m,
+ Read a, Typeable a, Eq a, Show a) =>
+ a -> String -> View view m (Radio a)
+setRadioActive v n = View $ do
+ st <- get
+ put st{needForm= HasElems }
+ let env = mfEnv st
+ mn <- getParam1 n env
+ let str = if typeOf v == typeOf(undefined :: String)
+ then unsafeCoerce v else show v
+ return $ FormElm (finput n "radio" str
+ ( isValidated mn && v== fromValidated mn) (Just "this.form.submit()"))
+ (fmap Radio $ valToMaybe mn)
+
+
+-- | Implement a radio button
+-- the parameter is the name of the radio group
+setRadio :: (FormInput view, MonadIO m,
+ Read a, Typeable a, Eq a, Show a) =>
+ a -> String -> View view m (Radio a)
+setRadio v n= View $ do
+ st <- get
+ put st{needForm= HasElems}
+ let env = mfEnv st
+ mn <- getParam1 n env
+ let str = if typeOf v == typeOf(undefined :: String)
+ then unsafeCoerce v else show v
+ return $ FormElm (finput n "radio" str
+ ( isValidated mn && v== fromValidated mn) Nothing)
+ (fmap Radio $ valToMaybe mn)
+
+-- | encloses a set of Radio boxes. Return the option selected
+getRadio
+ :: (Monad m, Functor m, FormInput view) =>
+ [String -> View view m (Radio a)] -> View view m a
+getRadio rs= do
+ id <- genNewId
+ Radio r <- firstOf $ map (\r -> r id) rs
+ return r
+
+data CheckBoxes = CheckBoxes [String]
+
+instance Monoid CheckBoxes where
+ mappend (CheckBoxes xs) (CheckBoxes ys)= CheckBoxes $ xs ++ ys
+ mempty= CheckBoxes []
+
+--instance (Monad m, Functor m) => Monoid (View v m CheckBoxes) where
+-- mappend x y= mappend <$> x <*> y
+-- mempty= return (CheckBoxes [])
+
+
+-- | Display a text box and return the value entered if it is readable( Otherwise, fail the validation)
+setCheckBox :: (FormInput view, MonadIO m) =>
+ Bool -> String -> View view m CheckBoxes
+setCheckBox checked v= View $ do
+ n <- genNewId
+ st <- get
+ put st{needForm= HasElems}
+ let env = mfEnv st
+ strs= map snd $ filter ((==) n . fst) env
+ mn= if null strs then Nothing else Just $ head strs
+ val = inSync st
+ let ret= case val of -- !> show val of
+ True -> Just $ CheckBoxes strs -- !> show strs
+ False -> Nothing
+ return $ FormElm
+ ( finput n "checkbox" v
+ ( checked || (isJust mn && v== fromJust mn)) Nothing)
+ ret
+
+-- | Read the checkboxes dinamically created by JavaScript within the view parameter
+-- see for example `selectAutocomplete` in "MFlow.Forms.Widgets"
+genCheckBoxes :: (Monad m, FormInput view) => view -> View view m CheckBoxes
+genCheckBoxes v= View $ do
+ n <- genNewId
+ st <- get
+ put st{needForm= HasElems}
+ let env = mfEnv st
+ strs= map snd $ filter ((==) n . fst) env
+ mn= if null strs then Nothing else Just $ head strs
+
+ val <- gets inSync
+ let ret= case val of
+ True -> Just $ CheckBoxes strs
+ False -> Nothing
+ return $ FormElm (ftag "span" v `attrs`[("id",n)]) ret
+
+whidden :: (Monad m, FormInput v,Read a, Show a, Typeable a) => a -> View v m a
+whidden x= View $ do
+ n <- genNewId
+ env <- gets mfEnv
+ let showx= case cast x of
+ Just x' -> x'
+ Nothing -> show x
+ r <- getParam1 n env
+ return . FormElm (finput n "hidden" showx False Nothing) $ valToMaybe r
+
+getCheckBoxes :: (FormInput view, Monad m)=> View view m CheckBoxes -> View view m [String]
+getCheckBoxes boxes = View $ do
+ n <- genNewId
+ st <- get
+ let env = mfEnv st
+ let form= finput n "hidden" "" False Nothing
+ mr <- getParam1 n env
+
+ let env = mfEnv st
+ modify $ \st -> st{needForm= HasElems}
+ FormElm form2 mr2 <- runView boxes
+ return $ FormElm (form <> form2) $
+ case (mr `asTypeOf` Validated ("" :: String),mr2) of
+ (NoParam,_) -> Nothing
+ (Validated _,Nothing) -> Just []
+ (Validated _, Just (CheckBoxes rs)) -> Just rs
+
+
+
+
+
+getTextBox
+ :: (FormInput view,
+ Monad m,
+ Typeable a,
+ Show a,
+ Read a) =>
+ Maybe a -> View view m a
+getTextBox ms = getParam Nothing "text" ms
+
+
+getParam
+ :: (FormInput view,
+ Monad m,
+ Typeable a,
+ Show a,
+ Read a) =>
+ Maybe String -> String -> Maybe a -> View view m a
+getParam look type1 mvalue = View $ do
+ tolook <- case look of
+ Nothing -> genNewId
+ Just n -> return n
+ let nvalue x = case x of
+ Nothing -> ""
+ Just v ->
+ case cast v of
+ Just v' -> v'
+ Nothing -> show v
+ st <- get
+ let env = mfEnv st
+ put st{needForm= HasElems}
+ r <- getParam1 tolook env
+ case r of
+ Validated x -> return $ FormElm (finput tolook type1 (nvalue $ Just x) False Nothing) $ Just x
+ NotValidated s err -> return $ FormElm (finput tolook type1 s False Nothing <> err) $ Nothing
+ NoParam -> return $ FormElm (finput tolook type1 (nvalue mvalue) False Nothing) $ Nothing
+
+
+
+--getCurrentName :: MonadState (MFlowState view) m => m String
+--getCurrentName= do
+-- st <- get
+-- let parm = mfSequence st
+-- return $ "p"++show parm
+
+
+-- | Display a multiline text box and return its content
+getMultilineText :: (FormInput view
+ , Monad m)
+ => T.Text
+ -> View view m T.Text
+getMultilineText nvalue = View $ do
+ tolook <- genNewId
+ env <- gets mfEnv
+ r <- getParam1 tolook env
+ case r of
+ Validated x -> return $ FormElm (ftextarea tolook x) $ Just x
+ NotValidated s err -> return $ FormElm (ftextarea tolook (T.pack s)) Nothing
+ NoParam -> return $ FormElm (ftextarea tolook nvalue) Nothing
+
+
+--instance (MonadIO m, Functor m, FormInput view) => FormLet Bool m view where
+-- digest mv = getBool b "True" "False"
+-- where
+-- b= case mv of
+-- Nothing -> Nothing
+-- Just bool -> Just $ case bool of
+-- True -> "True"
+-- False -> "False"
+
+-- | Display a dropdown box with the two values (second (true) and third parameter(false))
+-- . With the value of the first parameter selected.
+getBool :: (FormInput view,
+ Monad m, Functor m) =>
+ Bool -> String -> String -> View view m Bool
+getBool mv truestr falsestr= do
+ r <- getSelect $ setOption truestr (fromStr truestr) <! (if mv then [("selected","true")] else [])
+ <|> setOption falsestr(fromStr falsestr) <! if not mv then [("selected","true")] else []
+ if r == truestr then return True else return False
+
+
+
+-- | Display a dropdown box with the options in the first parameter is optionally selected
+-- . It returns the selected option.
+getSelect :: (FormInput view,
+ Monad m,Typeable a, Read a) =>
+ View view m (MFOption a) -> View view m a
+getSelect opts = View $ do
+ tolook <- genNewId
+ st <- get
+ let env = mfEnv st
+ put st{needForm= HasElems}
+ r <- getParam1 tolook env
+ setSessionData $ fmap MFOption $ valToMaybe r
+ FormElm form mr <- (runView opts)
+
+ return $ FormElm (fselect tolook form) $ valToMaybe r
+
+
+newtype MFOption a= MFOption a deriving Typeable
+
+instance (FormInput view,Monad m, Functor m) => Monoid (View view m (MFOption a)) where
+ mappend = (<|>)
+ mempty = Control.Applicative.empty
+
+-- | Set the option for getSelect. Options are concatenated with `<|>`
+setOption
+ :: (Monad m, Show a, Eq a, Typeable a, FormInput view) =>
+ a -> view -> View view m (MFOption a)
+setOption n v = do
+ mo <- getSessionData
+ case mo of
+ Nothing -> setOption1 n v False
+ Just Nothing -> setOption1 n v False
+ Just (Just (MFOption o)) -> setOption1 n v $ n == o
+
+-- | Set the selected option for getSelect. Options are concatenated with `<|>`
+setSelectedOption
+ :: (Monad m, Show a, Eq a, Typeable a, FormInput view) =>
+ a -> view -> View view m (MFOption a)
+setSelectedOption n v= do
+ mo <- getSessionData
+ case mo of
+ Nothing -> setOption1 n v True
+ Just Nothing -> setOption1 n v True
+ Just (Just o) -> setOption1 n v $ n == o
+
+
+setOption1 :: (FormInput view,
+ Monad m, Typeable a, Eq a, Show a) =>
+ a -> view -> Bool -> View view m (MFOption a)
+setOption1 nam val check= View $ do
+ st <- get
+ let env = mfEnv st
+ put st{needForm= HasElems}
+ let n = if typeOf nam == typeOf(undefined :: String)
+ then unsafeCoerce nam
+ else show nam
+
+ return . FormElm (foption n val check) . Just $ MFOption nam
+
+-- | upload a file to a temporary file in the server
+--
+-- The user can move, rename it etc.
+fileUpload :: (FormInput view,
+ Monad m,Functor m) =>
+ View view m (String
+ ,String
+ ,String
+ ) -- ^ ( original file, file type, temporal uploaded)
+fileUpload=
+ getParam Nothing "file" Nothing <** modify ( \st -> st{mfFileUpload = True})
+
+
+
+-- | Enclose Widgets within some formating.
+-- @view@ is intended to be instantiated to a particular format
+--
+-- NOTE: It has a infix priority : @infixr 5@ less than the one of @++>@ and @<++@ of the operators, so use parentheses when appropriate,
+-- unless the we want to enclose all the widgets in the right side.
+-- Most of the type errors in the DSL are due to the low priority of this operator.
+--
+-- This is a widget, which is a table with some links. it returns an Int
+--
+-- > import MFlow.Forms.Blaze.Html
+-- >
+-- > tableLinks :: View Html Int
+-- > table ! At.style "border:1;width:20%;margin-left:auto;margin-right:auto"
+-- > <<< caption << text "choose an item"
+-- > ++> thead << tr << ( th << b << text "item" <> th << b << text "times chosen")
+-- > ++> (tbody
+-- > <<< tr ! rowspan "2" << td << linkHome
+-- > ++> (tr <<< td <<< wlink IPhone (b << text "iphone") <++ td << ( b << text (fromString $ show ( cart V.! 0)))
+-- > <|> tr <<< td <<< wlink IPod (b << text "ipad") <++ td << ( b << text (fromString $ show ( cart V.! 1)))
+-- > <|> tr <<< td <<< wlink IPad (b << text "ipod") <++ td << ( b << text (fromString $ show ( cart V.! 2))))
+-- > )
+(<<<) :: (Monad m, Monoid view)
+ => (view ->view)
+ -> View view m a
+ -> View view m a
+(<<<) v form= View $ do
+ FormElm f mx <- runView form
+ return $ FormElm (v f) mx
+
+
+infixr 5 <<<
+
+
+
+
+
+
+-- | Append formatting code to a widget
+--
+-- @ getString "hi" '<++' H1 '<<' "hi there"@
+--
+-- It has a infix prority: @infixr 6@ higher than '<<<' and most other operators.
+(<++) :: (Monad m, Monoid v)
+ => View v m a
+ -> v
+ -> View v m a
+(<++) form v= View $ do
+ FormElm f mx <- runView form
+ return $ FormElm ( f <> v) mx
+
+infixr 6 ++>
+infixr 6 <++
+-- | Prepend formatting code to a widget
+--
+-- @bold '<<' "enter name" '++>' 'getString' 'Nothing' @
+--
+-- It has a infix prority: @infixr 6@ higher than '<<<' and most other operators
+(++>) :: (Monad m, Monoid view)
+ => view -> View view m a -> View view m a
+html ++> w = -- (html <>) <<< digest
+ View $ do
+ FormElm f mx <- runView w
+ return $ FormElm (html <> f) mx
+
+
+
+-- | Add attributes to the topmost tag of a widget
+--
+-- It has a fixity @infix 8@
+infixl 8 <!
+widget <! attribs= View $ do
+ FormElm fs mx <- runView widget
+ return $ FormElm (fs `attrs` attribs) mx -- (head fs `attrs` attribs:tail fs) mx
+-- case fs of
+-- [hfs] -> return $ FormElm [hfs `attrs` attribs] mx
+-- _ -> error $ "operator <! : malformed widget: "++ concatMap (unpack. toByteString) fs
+
+
+-- | Is an example of login\/register validation form needed by 'userWidget'. In this case
+-- the form field appears in a single line. it shows, in sequence, entries for the username,
+-- password, a button for loging, a entry to repeat password necesary for registering
+-- and a button for registering.
+-- The user can build its own user login\/validation forms by modifying this example
+--
+-- @ userFormLine=
+-- (User \<\$\> getString (Just \"enter user\") \<\*\> getPassword \<\+\> submitButton \"login\")
+-- \<\+\> fromStr \" password again\" \+\> getPassword \<\* submitButton \"register\"
+-- @
+userFormLine :: (FormInput view, Functor m, Monad m)
+ => View view m (Maybe (UserStr,PasswdStr), Maybe PasswdStr)
+userFormLine=
+ ((,) <$> getString (Just "enter user") <! [("size","5")]
+ <*> getPassword <! [("size","5")]
+ <** submitButton "login")
+ <+> (fromStr " password again" ++> getPassword <! [("size","5")]
+ <** submitButton "register")
+
+-- | Example of user\/password form (no validation) to be used with 'userWidget'
+userLogin :: (FormInput view, Functor m, Monad m)
+ => View view m (Maybe (UserStr,PasswdStr), Maybe String)
+userLogin=
+ ((,) <$> fromStr "Enter User: " ++> getString Nothing <! [("size","4")]
+ <*> fromStr " Enter Pass: " ++> getPassword <! [("size","4")]
+ <** submitButton "login")
+ <+> (noWidget
+ <* noWidget)
+
+
+
+-- | Empty widget that does not validate. May be used as \"empty boxes\" inside larger widgets.
+--
+-- It returns a non valid value.
+noWidget :: (FormInput view,
+ Monad m, Functor m) =>
+ View view m a
+noWidget= Control.Applicative.empty
-- | a sinonym of noWidget that can be used in a monadic expression in the View monad does not continue
-stop :: (FormInput view,
- Monad m, Functor m) =>
+stop :: (FormInput view,
+ Monad m, Functor m) =>
View view m a
stop= Control.Applicative.empty
-
--- | Render a Show-able value and return it
-wrender
- :: (Monad m, Functor m, Show a, FormInput view) =>
- a -> View view m a
-wrender x = (fromStr $ show x) ++> return x
-
--- | Render raw view formatting. It is useful for displaying information.
-wraw :: Monad m => view -> View view m ()
-wraw x= View . return . FormElm x $ Just ()
-
--- To display some rendering and return a no valid value
-notValid :: Monad m => view -> View view m a
-notValid x= View . return $ FormElm x Nothing
-
--- | Wether the user is logged or is anonymous
-isLogged :: MonadState (MFlowState v) m => m Bool
-isLogged= do
- rus <- return . tuser =<< gets mfToken
- return . not $ rus == anonymous
-
--- | return the result if going forward
---
--- If the process is backtraking, it does not validate,
--- in order to continue the backtracking
-returnIfForward :: (Monad m, FormInput view,Functor m) => b -> View view m b
-returnIfForward x = do
- back <- goingBack
- if back then noWidget else return x
-
--- | forces backtracking if the widget validates, because a previous page handle this widget response
--- . This is useful for recurrent cached widgets or `absLink`s that are present in multiple pages. For example
--- in the case of menus or common options. The active elements of this widget must be cached with no timeout.
-retry :: Monad m => View v m a -> View v m ()
-retry w = View $ do
- FormElm v mx <- runView w
- when (isJust mx) $ modify $ \st -> st{inSync = False}
- return $ FormElm v Nothing
-
--- | It creates a widget for user login\/registering. If a user name is specified
--- in the first parameter, it is forced to login\/password as this specific user.
--- If this user was already logged, the widget return the user without asking.
--- If the user press the register button, the new user-password is registered and the
--- user logged.
-
-userWidget :: ( MonadIO m, Functor m
- , FormInput view)
- => Maybe String
- -> View view m (Maybe (UserStr,PasswdStr), Maybe String)
- -> View view m String
-userWidget muser formuser = userWidget' muser formuser login1
-
--- | Uses 4 different keys to encrypt the 4 parts of a MFlow cookie.
-
-paranoidUserWidget muser formuser = userWidget' muser formuser paranoidLogin1
-
--- | Uses a single key to encrypt the MFlow cookie.
-
-encryptedUserWidget muser formuser = userWidget' muser formuser encryptedLogin1
-
-userWidget' muser formuser login1Func = do
- user <- getCurrentUser
- if muser== Just user || isNothing muser && user/= anonymous
- then returnIfForward user
- else formuser `validate` val muser `wcallback` login1Func
- where
- val _ (Nothing,_) = return . Just $ fromStr "Plese fill in the user/passwd to login, or user/passwd/passwd to register"
-
- val mu (Just us, Nothing)=
- if isNothing mu || isJust mu && fromJust mu == fst us
- then userValidate us
- else return . Just $ fromStr "This user has no permissions for this task"
-
- val mu (Just us, Just p)=
- if isNothing mu || isJust mu && fromJust mu == fst us
- then if Data.List.length p > 0 && snd us== p
- then return Nothing
- else return . Just $ fromStr "The passwords do not match"
- else return . Just $ fromStr "wrong user for the operation"
-
--- val _ _ = return . Just $ fromStr "Please fill in the fields for login or register"
-
-login1
- :: (MonadIO m, MonadState (MFlowState view) m) =>
- (Maybe (UserStr, PasswdStr), Maybe t) -> m UserStr
-login1 uname = login1' uname login
-
-paranoidLogin1 uname = login1' uname paranoidLogin
-
-encryptedLogin1 uname = login1' uname encryptedLogin
-
-login1' (Just (uname,_), Nothing) loginFunc= loginFunc uname >> return uname
-login1' (Just us@(u,p), Just _) loginFunc= do -- register button pressed
- userRegister u p
- loginFunc u
- return u
-
--- | change the user
---
--- It is supposed that the user has been validated
-
-login uname = login' uname setCookie
-
-paranoidLogin uname = login' uname setParanoidCookie
-
-encryptedLogin uname = login' uname setEncryptedCookie
-
-login'
- :: (Num a1, S.IsString a, MonadIO m,
- MonadState (MFlowState view) m) =>
- String -> (String -> String -> a -> Maybe a1 -> m ()) -> m ()
-login' uname setCookieFunc = do
- back <- goingBack
- if back then return () else do
- st <- get
- let t = mfToken st
- u = tuser t
- when (u /= uname) $ do
- let t'= t{tuser= uname}
- -- moveState (twfname t) t t'
- put st{mfToken= t'}
- liftIO $ deleteTokenInList t
- liftIO $ addTokenToList t'
- setCookieFunc cookieuser uname "/" (Just $ 365*24*60*60)
-
-logout = logout' setCookie
-
-paranoidLogout = logout' setParanoidCookie
-
-encryptedLogout = logout' setEncryptedCookie
-
-
--- | logout. The user is reset to the `anonymous` user
-logout'
- :: (Num a1,S.IsString a, MonadIO m,
- MonadState (MFlowState view) m) =>
- (String -> [Char] -> a -> Maybe a1 -> m ()) -> m ()
+
+-- | Render a Show-able value and return it
+wrender
+ :: (Monad m, Functor m, Show a, FormInput view) =>
+ a -> View view m a
+wrender x = (fromStr $ show x) ++> return x
+
+-- | Render raw view formatting. It is useful for displaying information.
+wraw :: Monad m => view -> View view m ()
+wraw x= View . return . FormElm x $ Just ()
+
+-- To display some rendering and return a no valid value
+notValid :: Monad m => view -> View view m a
+notValid x= View . return $ FormElm x Nothing
+
+-- | Wether the user is logged or is anonymous
+isLogged :: MonadState (MFlowState v) m => m Bool
+isLogged= do
+ rus <- return . tuser =<< gets mfToken
+ return . not $ rus == anonymous
+
+-- | return the result if going forward
+--
+-- If the process is backtraking, it does not validate,
+-- in order to continue the backtracking
+returnIfForward :: (Monad m, FormInput view,Functor m) => b -> View view m b
+returnIfForward x = do
+ back <- goingBack
+ if back then noWidget else return x
+
+-- | forces backtracking if the widget validates, because a previous page handle this widget response
+-- . This is useful for recurrent cached widgets or `absLink`s that are present in multiple pages. For example
+-- in the case of menus or common options. The active elements of this widget must be cached with no timeout.
+retry :: Monad m => View v m a -> View v m ()
+retry w = View $ do
+ FormElm v mx <- runView w
+ when (isJust mx) $ modify $ \st -> st{inSync = False}
+ return $ FormElm v Nothing
+
+-- | It creates a widget for user login\/registering. If a user name is specified
+-- in the first parameter, it is forced to login\/password as this specific user.
+-- If this user was already logged, the widget return the user without asking.
+-- If the user press the register button, the new user-password is registered and the
+-- user logged.
+
+userWidget :: ( MonadIO m, Functor m
+ , FormInput view)
+ => Maybe String
+ -> View view m (Maybe (UserStr,PasswdStr), Maybe String)
+ -> View view m String
+userWidget muser formuser = userWidget' muser formuser login1
+
+-- | Uses 4 different keys to encrypt the 4 parts of a MFlow cookie.
+
+paranoidUserWidget muser formuser = userWidget' muser formuser paranoidLogin1
+
+-- | Uses a single key to encrypt the MFlow cookie.
+
+encryptedUserWidget muser formuser = userWidget' muser formuser encryptedLogin1
+
+userWidget' muser formuser login1Func = do
+ user <- getCurrentUser
+ if muser== Just user || isNothing muser && user/= anonymous
+ then returnIfForward user
+ else formuser `validate` val muser `wcallback` login1Func
+ where
+ val _ (Nothing,_) = return . Just $ fromStr "Plese fill in the user/passwd to login, or user/passwd/passwd to register"
+
+ val mu (Just us, Nothing)=
+ if isNothing mu || isJust mu && fromJust mu == fst us
+ then userValidate us
+ else return . Just $ fromStr "This user has no permissions for this task"
+
+ val mu (Just us, Just p)=
+ if isNothing mu || isJust mu && fromJust mu == fst us
+ then if Data.List.length p > 0 && snd us== p
+ then return Nothing
+ else return . Just $ fromStr "The passwords do not match"
+ else return . Just $ fromStr "wrong user for the operation"
+
+-- val _ _ = return . Just $ fromStr "Please fill in the fields for login or register"
+
+login1
+ :: (MonadIO m, MonadState (MFlowState view) m) =>
+ (Maybe (UserStr, PasswdStr), Maybe t) -> m UserStr
+login1 uname = login1' uname login
+
+paranoidLogin1 uname = login1' uname paranoidLogin
+
+encryptedLogin1 uname = login1' uname encryptedLogin
+
+login1' (Just (uname,_), Nothing) loginFunc= loginFunc uname >> return uname
+login1' (Just us@(u,p), Just _) loginFunc= do -- register button pressed
+ userRegister u p
+ loginFunc u
+ return u
+
+-- | change the user
+--
+-- It is supposed that the user has been validated
+
+login uname = login' uname setCookie
+
+paranoidLogin uname = login' uname setParanoidCookie
+
+encryptedLogin uname = login' uname setEncryptedCookie
+
+login'
+ :: (Num a1, S.IsString a, MonadIO m,
+ MonadState (MFlowState view) m) =>
+ String -> (String -> String -> a -> Maybe a1 -> m ()) -> m ()
+login' uname setCookieFunc = do
+ back <- goingBack
+ if back then return () else do
+ st <- get
+ let t = mfToken st
+ u = tuser t
+ when (u /= uname) $ do
+ let t'= t{tuser= uname}
+ -- moveState (twfname t) t t'
+ put st{mfToken= t'}
+ liftIO $ deleteTokenInList t
+ liftIO $ addTokenToList t'
+ setCookieFunc cookieuser uname "/" (Just $ 365*24*60*60)
+
+logout = logout' setCookie
+
+paranoidLogout = logout' setParanoidCookie
+
+encryptedLogout = logout' setEncryptedCookie
+
+
+-- | logout. The user is reset to the `anonymous` user
+logout'
+ :: (Num a1,S.IsString a, MonadIO m,
+ MonadState (MFlowState view) m) =>
+ (String -> [Char] -> a -> Maybe a1 -> m ()) -> m ()
logout' setCookieFunc = do
- public
- back <- goingBack
- if back then return () else do
- st <- get
- let t = mfToken st
- t'= t{tuser= anonymous}
- when (tuser t /= anonymous) $ do
--- moveState (twfname t) t t'
- put st{mfToken= t'}
--- liftIO $ deleteTokenInList t
- liftIO $ addTokenToList t'
- setCookieFunc cookieuser anonymous "/" (Just $ -1000)
-
--- | If not logged, perform login. otherwise return the user
---
--- @getUserSimple= getUser Nothing userFormLine@
-getUserSimple :: ( FormInput view, Typeable view)
- => FlowM view IO String
-getUserSimple= getUser Nothing userFormLine
-
--- | Very basic user authentication. The user is stored in a cookie.
--- it looks for the cookie. If no cookie, it ask to the user for a `userRegister`ed
--- user-password combination.
--- The user-password combination is only asked if the user has not logged already
--- otherwise, the stored username is returned.
---
--- @getUser mu form= ask $ userWidget mu form@
-getUser :: ( FormInput view, Typeable view)
- => Maybe String
- -> View view IO (Maybe (UserStr,PasswdStr), Maybe String)
- -> FlowM view IO String
-getUser mu form= ask $ userWidget mu form
-
--- | Authentication against `userRegister`ed users.
--- to be used with `validate`
-userValidate :: (FormInput view,MonadIO m) => (UserStr,PasswdStr) -> m (Maybe view)
-userValidate (u,p) = liftIO $ do
- Auth _ val <- getAuthMethod
- val u p >>= return . fmap fromStr
-
-
-
--- | for compatibility with the same procedure in 'MFLow.Forms.Test.askt'.
--- This is the non testing version
---
--- > askt v w= ask w
---
--- hide one or the other
-askt :: FormInput v => (Int -> a) -> View v IO a -> FlowM v IO a
-askt v w = ask w
-
-
--- | It is the way to interact with the user.
--- It takes a widget and return the input result. If the widget is not validated (return @Nothing@)
--- , the page is presented again
---
--- If the environment or the URL has the parameters being looked at, maybe as a result of a previous interaction,
--- it will not ask to the user and return the result.
--- To force asking in any case, add an `clearEnv` statement before.
--- It also handles ajax requests
---
--- 'ask' also synchronizes the execution of the flow with the user page navigation by
-
--- * Backtracking (invoking previous 'ask' staement in the flow) when detecting mismatches between
--- get and post parameters and what is expected by the widgets
--- until a total or partial match is found.
---
--- * Advancing in the flow by matching a single requests with one or more sucessive ask statements
---
--- Backtracking and advancing can occur in a single request, so the flow in any state can reach any
--- other state in the flow if the request has the required parameters.
-ask :: (FormInput view) =>
- View view IO a -> FlowM view IO a
+ public
+ back <- goingBack
+ if back then return () else do
+ st <- get
+ let t = mfToken st
+ t'= t{tuser= anonymous}
+ when (tuser t /= anonymous) $ do
+-- moveState (twfname t) t t'
+ put st{mfToken= t'}
+-- liftIO $ deleteTokenInList t
+ liftIO $ addTokenToList t'
+ setCookieFunc cookieuser anonymous "/" (Just $ -1000)
+
+-- | If not logged, perform login. otherwise return the user
+--
+-- @getUserSimple= getUser Nothing userFormLine@
+getUserSimple :: ( FormInput view, Typeable view)
+ => FlowM view IO String
+getUserSimple= getUser Nothing userFormLine
+
+-- | Very basic user authentication. The user is stored in a cookie.
+-- it looks for the cookie. If no cookie, it ask to the user for a `userRegister`ed
+-- user-password combination.
+-- The user-password combination is only asked if the user has not logged already
+-- otherwise, the stored username is returned.
+--
+-- @getUser mu form= ask $ userWidget mu form@
+getUser :: ( FormInput view, Typeable view)
+ => Maybe String
+ -> View view IO (Maybe (UserStr,PasswdStr), Maybe String)
+ -> FlowM view IO String
+getUser mu form= ask $ userWidget mu form
+
+-- | Authentication against `userRegister`ed users.
+-- to be used with `validate`
+userValidate :: (FormInput view,MonadIO m) => (UserStr,PasswdStr) -> m (Maybe view)
+userValidate (u,p) = liftIO $ do
+ Auth _ val <- getAuthMethod
+ val u p >>= return . fmap fromStr
+
+
+
+-- | for compatibility with the same procedure in 'MFLow.Forms.Test.askt'.
+-- This is the non testing version
+--
+-- > askt v w= ask w
+--
+-- hide one or the other
+askt :: FormInput v => (Int -> a) -> View v IO a -> FlowM v IO a
+askt v w = ask w
+
+
+-- | It is the way to interact with the user.
+-- It takes a widget and return the input result. If the widget is not validated (return @Nothing@)
+-- , the page is presented again
+--
+-- If the environment or the URL has the parameters being looked at, maybe as a result of a previous interaction,
+-- it will not ask to the user and return the result.
+-- To force asking in any case, add an `clearEnv` statement before.
+-- It also handles ajax requests
+--
+-- 'ask' also synchronizes the execution of the flow with the user page navigation by
+
+-- * Backtracking (invoking previous 'ask' staement in the flow) when detecting mismatches between
+-- get and post parameters and what is expected by the widgets
+-- until a total or partial match is found.
+--
+-- * Advancing in the flow by matching a single requests with one or more sucessive ask statements
+--
+-- Backtracking and advancing can occur in a single request, so the flow in any state can reach any
+-- other state in the flow if the request has the required parameters.
+ask :: (FormInput view) =>
+ View view IO a -> FlowM view IO a
ask w = do
- resetCachePolicy
+ resetCachePolicy
st1 <- get >>= \s -> return s{mfSequence=
let seq= mfSequence s in
if seq ==inRecovery then 0 else seq
- ,mfHttpHeaders =[],mfAutorefresh= False }
- if not . null $ mfTrace st1 then fail "" else do
- -- AJAX
- let env= mfEnv st1
- mv1= lookup "ajax" env
- majax1= mfAjax st1
-
- case (majax1,mv1,M.lookup (fromJust mv1)(fromJust majax1), lookup "val" env) of
- (Just ajaxl,Just v1,Just f, Just v2) -> do
- FlowM . lift $ (unsafeCoerce f) v2
- FlowM $ lift nextMessage
- ask w
- -- END AJAX
-
+ ,mfHttpHeaders =[],mfAutorefresh= False }
+ if not . null $ mfTrace st1 then fail "" else do
+ -- AJAX
+ let env= mfEnv st1
+ mv1= lookup "ajax" env
+ majax1= mfAjax st1
+
+ case (majax1,mv1,M.lookup (fromJust mv1)(fromJust majax1), lookup "val" env) of
+ (Just ajaxl,Just v1,Just f, Just v2) -> do
+ FlowM . lift $ (unsafeCoerce f) v2
+ FlowM $ lift nextMessage
+ ask w
+ -- END AJAX
+
_ -> do
-- mfPagePath : contains the REST path of the page.
@@ -1044,252 +1052,250 @@
-- if exist and it is not prefix of the current path being navigated to, backtrack
else if not $ pagepath `isPrefixOf` mfPath st1 then fail "" -- !> ("pagepath fail with "++ show (mfPath st1))
else do
-
- let st= st1{needForm= NoElems, inSync= False, mfRequirements= [], linkMatched= False}
- put st
- FormElm forms mx <- FlowM . lift $ runView w
- setCachePolicy
- st' <- get
- if notSyncInAction st' then put st'{notSyncInAction=False}>> ask w
-
- else
- case mx of
- Just x -> do
- put st'{newAsk= True, mfEnv=[]}
- breturn x -- !> ("BRETURN "++ show (mfPagePath st') )
-
- Nothing ->
- if not (inSync st') && not (newAsk st')
- -- !> ("insync="++show (inSync st'))
- -- !> ("newask="++show (newAsk st'))
- then fail "" -- !> "FAIL sync"
- else if mfAutorefresh st' then do
- resetState st st' -- !> ("EN AUTOREFRESH" ++ show [ mfPagePath st,mfPath st,mfPagePath st'])
+
+ let st= st1{needForm= NoElems, inSync= False, linkMatched= False
+ ,mfRequirements= []
+ ,mfInstalledScripts= if newAsk st1 then [] else mfInstalledScripts st1}
+ put st
+ FormElm forms mx <- FlowM . lift $ runView w
+ setCachePolicy
+ st' <- get
+ if notSyncInAction st' then put st'{notSyncInAction=False}>> ask w
+
+ else
+ case mx of
+ Just x -> do
+ put st'{newAsk= True, mfEnv=[]}
+ breturn x -- !> ("BRETURN "++ show (mfPagePath st') )
+
+ Nothing ->
+ if not (inSync st') && not (newAsk st')
+ -- !> ("insync="++show (inSync st'))
+ -- !> ("newask="++show (newAsk st'))
+ then fail "" -- !> "FAIL sync"
+ else if mfAutorefresh st' then do
+ resetState st st' -- !> ("EN AUTOREFRESH" ++ show [ mfPagePath st,mfPath st,mfPagePath st'])
-- modify $ \st -> st{mfPagePath=mfPagePath st'} !> "REPEAT"
- FlowM $ lift nextMessage
- ask w
- else do
+ FlowM $ lift nextMessage
+ ask w
+ else do
reqs <- FlowM $ lift installAllRequirements -- !> "REPEAT"
-
- let header= mfHeader st'
- t= mfToken st'
- cont <- case (needForm1 st') of
- True -> do
- frm <- formPrefix st' forms False -- !> ("formPrefix="++ show(mfPagePath st'))
- return . header $ reqs <> frm
- _ -> return . header $ reqs <> forms
-
- let HttpData ctype c s= toHttpData cont
- liftIO . sendFlush t $ HttpData (ctype ++ mfHttpHeaders st') (mfCookies st' ++ c) s
-
-
- resetState st st'
+ st' <- get
+ let header= mfHeader st'
+ t= mfToken st'
+ cont <- case (needForm st') of
+ HasElems -> do
+ frm <- formPrefix st' forms False -- !> ("formPrefix="++ show(mfPagePath st'))
+ return . header $ reqs <> frm
+ _ -> return . header $ reqs <> forms
+
+ let HttpData ctype c s= toHttpData cont
+ liftIO . sendFlush t $ HttpData (ctype ++ mfHttpHeaders st') (mfCookies st' ++ c) s
+
+ resetState st st'
FlowM $ lift nextMessage -- !> "NEXTMESSAGE"
- ask w
- where
- resetState st st'=
- put st{mfCookies=[]
- -- ,mfHttpHeaders=[]
- ,newAsk= False
- ,mfToken= mfToken st'
- ,mfPageFlow= mfPageFlow st'
- ,mfAjax= mfAjax st'
--- ,mfSeqCache= mfSeqCache st'
- ,mfData= mfData st' }
-
-
--- | A synonym of ask.
---
--- Maybe more appropiate for pages with long interactions with the user
--- while the result has little importance.
-page
- :: (FormInput view) =>
- View view IO a -> FlowM view IO a
-page= ask
-
-nextMessage :: MonadIO m => WState view m ()
-nextMessage = do
- st <- get
- let t= mfToken st
- t1= mfkillTime st
- t2= mfSessionTime st
- msg <- liftIO ( receiveReqTimeout t1 t2 t)
- let req= getParams msg
- env= updateParams inPageFlow (mfEnv st) req -- !> ("PAGEFLOW="++ show inPageFlow)
- npath= pwfPath msg
- path= mfPath st
- inPageFlow= mfPagePath st `isPrefixOf` npath
-
- put st{ mfPath= npath
-
-
- , mfPageFlow= inPageFlow
-
- , mfEnv= env }
-
-
- where
-
- comparePaths _ n [] xs= n
- comparePaths o n _ [] = o
- comparePaths o n (v:path) (v': npath) | v== v' = comparePaths o (n+1)path npath
- | otherwise= n
-
- updateParams :: Bool -> Params -> Params -> Params
- updateParams False _ req= req
- updateParams True env req=
- let params= takeWhile isparam env
- fs= fst $ head req
- parms= (case findIndex (\p -> fst p == fs) params of
- Nothing -> params
- Just i -> Data.List.take i params)
- ++ req
- in parms
--- !> "IN PAGE FLOW" !> ("parms=" ++ show parms )
--- !> ("env=" ++ show env)
--- !> ("req=" ++ show req)
-
-
-
-isparam ('p': r:_,_)= isNumber r
-isparam ('c': r:_,_)= isNumber r
-isparam _= False
-
--- | Creates a stateless flow (see `stateless`) whose behaviour is defined as a widget. It is a
--- higuer level form of the latter
-wstateless
- :: (Typeable view, FormInput view) =>
- View view IO () -> Flow
-wstateless w = runFlow . transientNav . ask $ w **> (stop `asTypeOf` w)
-
-
-
-
-
-
--- | Wrap a widget with form element within a form-action element.
--- Usually this is not necessary since this wrapping is done automatically by the @Wiew@ monad, unless
--- there are more than one form in the page.
-wform :: (Monad m, FormInput view)
- => View view m b -> View view m b
-wform x = View $ do
- FormElm form mr <- (runView $ x )
- st <- get
- form1 <- formPrefix st form True
- put st{needForm=HasForm}
- return $ FormElm form1 mr
-
-
-
-
-resetButton :: (FormInput view, Monad m) => String -> View view m ()
+ ask w
+ where
+ resetState st st'=
+ put st{mfCookies=[]
+ ,mfInstalledScripts= mfInstalledScripts st'
+ ,newAsk= False
+ ,mfToken= mfToken st'
+ ,mfPageFlow= mfPageFlow st'
+ ,mfAjax= mfAjax st'
+ ,mfData= mfData st' }
+
+
+-- | A synonym of ask.
+--
+-- Maybe more appropiate for pages with long interactions with the user
+-- while the result has little importance.
+page
+ :: (FormInput view) =>
+ View view IO a -> FlowM view IO a
+page= ask
+
+nextMessage :: MonadIO m => WState view m ()
+nextMessage = do
+ st <- get
+ let t= mfToken st
+ t1= mfkillTime st
+ t2= mfSessionTime st
+ msg <- liftIO ( receiveReqTimeout t1 t2 t)
+ let req= getParams msg
+ env= updateParams inPageFlow (mfEnv st) req -- !> ("PAGEFLOW="++ show inPageFlow)
+ npath= pwfPath msg
+ path= mfPath st
+ inPageFlow= mfPagePath st `isPrefixOf` npath
+
+ put st{ mfPath= npath
+ , mfPageFlow= inPageFlow
+ , mfEnv= env }
+
+ where
+
+-- comparePaths _ n [] xs= n
+-- comparePaths o n _ [] = o
+-- comparePaths o n (v:path) (v': npath) | v== v' = comparePaths o (n+1)path npath
+-- | otherwise= n
+
+ updateParams :: Bool -> Params -> Params -> Params
+ updateParams False _ req= req
+ updateParams True env req=
+ let params= takeWhile isparam req -- env
+ fs= fst $ head req
+ parms= (case findIndex (\p -> fst p == fs) params of
+ Nothing -> params
+ Just i -> Data.List.take i params)
+ ++ req
+ in parms
+-- !> "IN PAGE FLOW" !> ("parms=" ++ show parms )
+-- !> ("env=" ++ show env)
+-- !> ("req=" ++ show req)
+
+
+
+isparam ('p': r:_,_)= isNumber r
+isparam ('c': r:_,_)= isNumber r
+isparam _= False
+
+-- | Creates a stateless flow (see `stateless`) whose behaviour is defined as a widget. It is a
+-- higuer level form of the latter
+wstateless
+ :: (Typeable view, FormInput view) =>
+ View view IO () -> Flow
+wstateless w = runFlow . transientNav . ask $ w **> (stop `asTypeOf` w)
+
+
+
+
+
+
+-- | Wrap a widget with form element within a form-action element.
+-- Usually this is not necessary since this wrapping is done automatically by the @Wiew@ monad, unless
+-- there are more than one form in the page.
+wform :: (Monad m, FormInput view)
+ => View view m b -> View view m b
+wform= insertForm
+--wform x = View $ do
+-- FormElm form mr <- (runView $ x )
+-- st <- get
+-- form1 <- formPrefix st form True
+-- put st{needForm=HasForm}
+-- return $ FormElm form1 mr
+
+
+
+
+resetButton :: (FormInput view, Monad m) => String -> View view m ()
resetButton label= View $ return $ FormElm (finput "reset" "reset" label False Nothing)
- $ Just ()
-
-submitButton :: (FormInput view, Monad m) => String -> View view m String
-submitButton label= getParam Nothing "submit" $ Just label
-
-newtype AjaxSessionId= AjaxSessionId String deriving Typeable
-
--- | Install the server code and return the client code for an AJAX interaction.
--- It is very lightweight, It does no t need jQuery.
---
--- This example increases the value of a text box each time the box is clicked
---
--- > ask $ do
--- > let elemval= "document.getElementById('text1').value"
--- > ajaxc <- ajax $ \n -> return $ elemval <> "='" <> B.pack(show(read n +1)) <> "'"
--- > b << text "click the box"
--- > ++> getInt (Just 0) <! [("id","text1"),("onclick", ajaxc elemval)]
-ajax :: (MonadIO m, FormInput v)
- => (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
- -> 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
-ajax f = do
- requires[JScript ajaxScript]
- t <- gets mfToken
- id <- genNewId
- installServerControl id $ \x-> do
- setSessionData $ AjaxSessionId id
- r <- f x
- liftIO $ sendFlush t (HttpData [("Content-Type", "text/plain")][] r )
- return ()
-
-installServerControl :: (FormInput v,MonadIO m) => String -> (String -> View v m ()) -> View v m (String -> String)
-installServerControl id f= do
- t <- gets mfToken
- st <- get
- let ajxl = fromMaybe M.empty $ mfAjax st
- let ajxl'= M.insert id (unsafeCoerce f ) ajxl
- put st{mfAjax=Just ajxl'}
- return $ \param -> "doServer("++"'" ++ twfname t ++"','"++id++"',"++ param++")"
-
--- | Send the javascript expression, generated by the procedure parameter as a ByteString, execute it in the browser and the result is returned back
---
--- The @ajaxSend@ invocation must be inside a ajax procedure or else a /No ajax session set/ error will be produced
-ajaxSend
- :: (Read a,Monoid v, MonadIO m) => View v m ByteString -> View v m a
-ajaxSend cmd= View $ do
- AjaxSessionId id <- getSessionData `onNothing` error "no AjaxSessionId set"
- env <- getEnv
- t <- getToken
- case (lookup "ajax" $ env, lookup "val" env) of
- (Nothing,_) -> return $ FormElm mempty Nothing
- (Just id, Just _) -> do
- FormElm __ (Just str) <- runView cmd
- liftIO $ sendFlush t $ HttpData [("Content-Type", "text/plain")][] $ str <> readEvalLoop t id "''"
- nextMessage
- env <- getEnv
- case (lookup "ajax" $ env,lookup "val" env) of
- (Nothing,_) -> return $ FormElm mempty Nothing
- (Just id, Just v2) -> do
- return $ FormElm mempty . Just $ read v2
- where
- readEvalLoop t id v = "doServer('"<> fromString (twfname t)<>"','"<> fromString id<>"',"<>v<>");" :: ByteString
-
--- | Like @ajaxSend@ but the result is ignored
-ajaxSend_
- :: (MonadIO m, Monoid v) => View v m ByteString -> View v m ()
-ajaxSend_ = ajaxSend
-
-wlabel
- :: (Monad m, FormInput view) => view -> View view m a -> View view m a
-wlabel str w = do
- id <- genNewId
- ftag "label" str `attrs` [("for",id)] ++> w <! [("id",id)]
-
-
+ $ Just ()
+
+submitButton :: (FormInput view, Monad m) => String -> View view m String
+submitButton label= getParam Nothing "submit" $ Just label
+
+newtype AjaxSessionId= AjaxSessionId String deriving Typeable
+
+-- | Install the server code and return the client code for an AJAX interaction.
+-- It is very lightweight, It does no t need jQuery.
+--
+-- This example increases the value of a text box each time the box is clicked
+--
+-- > ask $ do
+-- > let elemval= "document.getElementById('text1').value"
+-- > ajaxc <- ajax $ \n -> return $ elemval <> "='" <> B.pack(show(read n +1)) <> "'"
+-- > b << text "click the box"
+-- > ++> getInt (Just 0) <! [("id","text1"),("onclick", ajaxc elemval)]
+ajax :: (MonadIO m, FormInput v)
+ => (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
+ -> 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
+ajax f = do
+ requires[JScript ajaxScript]
+ t <- gets mfToken
+ id <- genNewId
+ installServerControl id $ \x-> do
+ setSessionData $ AjaxSessionId id
+ r <- f x
+ liftIO $ sendFlush t (HttpData [("Content-Type", "text/plain")][] r )
+ return ()
+
+installServerControl :: (FormInput v,MonadIO m) => String -> (String -> View v m ()) -> View v m (String -> String)
+installServerControl id f= do
+ t <- gets mfToken
+ st <- get
+ let ajxl = fromMaybe M.empty $ mfAjax st
+ let ajxl'= M.insert id (unsafeCoerce f ) ajxl
+ put st{mfAjax=Just ajxl'}
+ return $ \param -> "doServer("++"'" ++ twfname t ++"','"++id++"',"++ param++")"
+
+-- | Send the javascript expression, generated by the procedure parameter as a ByteString, execute it in the browser and the result is returned back
+--
+-- The @ajaxSend@ invocation must be inside a ajax procedure or else a /No ajax session set/ error will be produced
+ajaxSend
+ :: (Read a,Monoid v, MonadIO m) => View v m ByteString -> View v m a
+ajaxSend cmd= View $ do
+ AjaxSessionId id <- getSessionData `onNothing` error "no AjaxSessionId set"
+ env <- getEnv
+ t <- getToken
+ case (lookup "ajax" $ env, lookup "val" env) of
+ (Nothing,_) -> return $ FormElm mempty Nothing
+ (Just id, Just _) -> do
+ FormElm __ (Just str) <- runView cmd
+ liftIO $ sendFlush t $ HttpData [("Content-Type", "text/plain")][] $ str <> readEvalLoop t id "''"
+ nextMessage
+ env <- getEnv
+ case (lookup "ajax" $ env,lookup "val" env) of
+ (Nothing,_) -> return $ FormElm mempty Nothing
+ (Just id, Just v2) -> do
+ return $ FormElm mempty . Just $ read v2
+ where
+ readEvalLoop t id v = "doServer('"<> fromString (twfname t)<>"','"<> fromString id<>"',"<>v<>");" :: ByteString
+
+-- | Like @ajaxSend@ but the result is ignored
+ajaxSend_
+ :: (MonadIO m, Monoid v) => View v m ByteString -> View v m ()
+ajaxSend_ = ajaxSend
+
+wlabel
+ :: (Monad m, FormInput view) => view -> View view m a -> View view m a
+wlabel str w = do
+ id <- genNewId
+ ftag "label" str `attrs` [("for",id)] ++> w <! [("id",id)]
+
+
-- | Creates a link to a the next step within the flow.
-- A link can be composed with other widget elements.
-- It can not be broken by its own definition.
--- It points to the page that created it.
-wlink :: (Typeable a, Show a, MonadIO m, FormInput view)
- => a -> view -> View view m a
-wlink x v= View $ do
- verb <- getWFName
+-- It points to the page that created it.
+wlink :: (Typeable a, Show a, MonadIO m, FormInput view)
+ => a -> view -> View view m a
+wlink x v= View $ do
+ verb <- getWFName
st <- get
-
- let name = mfPrefix st ++ (map toLower $ if typeOf x== typeOf(undefined :: String)
- then unsafeCoerce x
- else show x)
+
+ let name = --mfPrefix st ++
+ (map toLower $ if typeOf x== typeOf(undefined :: String)
+ then unsafeCoerce x
+ else show x)
lpath = mfPath st
- newPath= mfPagePath st ++ [name]
-
- r <- if linkMatched st then return Nothing -- only a link match per page or monadic sentence in page
- else
- case newPath `isPrefixOf` lpath of
- True -> do
- modify $ \s -> s{inSync= True
+ newPath= mfPagePath st ++ [name]
+
+ r <- if linkMatched st then return Nothing -- only a link match per page or monadic sentence in page
+ else
+ case newPath `isPrefixOf` lpath of
+ True -> do
+ modify $ \s -> s{inSync= True
,linkMatched= True
- ,mfPagePath= newPath }
-
+ ,mfPagePath= newPath }
+
return $ Just x
--- !> (name ++ "<-" ++ "link path=" ++show newPath)
+-- !> (name ++ "<-" ++ "link path=" ++show newPath)
False -> return Nothing
-- !> ( "NOT MATCHED "++name++" link path= "++show newPath
--- ++ "path="++ show lpath)
+-- ++ "path="++ show lpath)
- let path= concat ['/':v| v <- newPath ]
- return $ FormElm (flink path v) r
+ let path= concat ['/':v| v <- newPath ]
+ return $ FormElm (flink path v) r
-- Creates an absolute link. While a `wlink` path depend on the page where it is located and
-- ever points to the code of the page that had it inserted, an absLink point to the first page
@@ -1313,299 +1319,300 @@
-- > p << "third statement" ++> (absLink "here" << p << "will present the first statement alone")
-- > p << "fourth statement" ++> wlink () << p << "will not reach here"
--absLink x = wcached (show x) 0 . wlink x
-absLink x v= View $ do
- verb <- getWFName
+absLink x v= View $ do
+ verb <- getWFName
st <- get
-
- let name = mfPrefix st ++ (map toLower $ if typeOf x== typeOf(undefined :: String)
- then unsafeCoerce x
- else show x)
+
+ let name = -- mfPrefix st
+ (map toLower $ if typeOf x== typeOf(undefined :: String)
+ then unsafeCoerce x
+ else show x)
lpath = mfPath st
- newPath= mfPagePath st ++ [name]
- r <- if linkMatched st then return Nothing -- only a link match per page or monadic sentence in page
- else
- case newPath `isPrefixOf` lpath of
- True -> do
- modify $ \s -> s{inSync= True
+ newPath= mfPagePath st ++ [name]
+ r <- if linkMatched st then return Nothing -- only a link match per page or monadic sentence in page
+ else
+ case newPath `isPrefixOf` lpath of
+ True -> do
+ modify $ \s -> s{inSync= True
,linkMatched= True
- ,mfPagePath= newPath }
-
- return $ Just x -- !> (name ++ "<- abs" ++ "lpath=" ++show lpath)
- False -> return Nothing -- !> ( "NOT MATCHED "++name++" LP= "++show lpath)
-
- path <- liftIO $ cachedByKey (show x) 0 . return $ currentPath st ++ ('/':name)
-
- return $ FormElm (flink path v) r -- !> name
-
-
-
--- | When some user interface return some response to the server, but it is not produced by
--- a form or a link, but for example by an script, @returning@ convert this code into a
--- widget.
---
--- At runtime the parameter is read from the environment and validated.
---
--- . The parameter is the visualization code, that accept a serialization function that generate
--- the server invocation string, used by the visualization to return the value by means
--- of an script, usually.
-returning :: (Typeable a, Read a, Show a,Monad m, FormInput view)
- => ((a->String) ->view) -> View view m a
-returning expr=View $ do
- verb <- getWFName
- name <- genNewId
- env <- gets mfEnv
- let string x=
- let showx= case cast x of
- Just x' -> x'
- _ -> show x
- in (verb ++ "?" ++ name ++ "=" ++ showx)
- toSend= expr string
- r <- getParam1 name env
- return $ FormElm toSend $ valToMaybe r
-
-
-
-
-
---instance (Widget a b m view, Monoid view) => Widget [a] b m view where
--- widget xs = View $ do
--- forms <- mapM(\x -> (runView $ widget x )) xs
--- let vs = concatMap (\(FormElm v _) -> v) forms
--- res = filter isJust $ map (\(FormElm _ r) -> r) forms
--- res1= if null res then Nothing else head res
--- return $ FormElm [mconcat vs] res1
-
--- | Concat a list of widgets of the same type, return a the first validated result
-firstOf :: (FormInput view, Monad m, Functor m)=> [View view m a] -> View view m a
+ ,mfPagePath= newPath }
+
+ return $ Just x -- !> (name ++ "<- abs" ++ "lpath=" ++show lpath)
+ False -> return Nothing -- !> ( "NOT MATCHED "++name++" LP= "++show lpath)
+
+ path <- liftIO $ cachedByKey (show x) 0 . return $ currentPath st ++ ('/':name)
+
+ return $ FormElm (flink path v) r -- !> name
+
+
+
+-- | When some user interface return some response to the server, but it is not produced by
+-- a form or a link, but for example by an script, @returning@ convert this code into a
+-- widget.
+--
+-- At runtime the parameter is read from the environment and validated.
+--
+-- . The parameter is the visualization code, that accept a serialization function that generate
+-- the server invocation string, used by the visualization to return the value by means
+-- of an script, usually.
+returning :: (Typeable a, Read a, Show a,Monad m, FormInput view)
+ => ((a->String) ->view) -> View view m a
+returning expr=View $ do
+ verb <- getWFName
+ name <- genNewId
+ env <- gets mfEnv
+ let string x=
+ let showx= case cast x of
+ Just x' -> x'
+ _ -> show x
+ in (verb ++ "?" ++ name ++ "=" ++ showx)
+ toSend= expr string
+ r <- getParam1 name env
+ return $ FormElm toSend $ valToMaybe r
+
+
+
+
+
+--instance (Widget a b m view, Monoid view) => Widget [a] b m view where
+-- widget xs = View $ do
+-- forms <- mapM(\x -> (runView $ widget x )) xs
+-- let vs = concatMap (\(FormElm v _) -> v) forms
+-- res = filter isJust $ map (\(FormElm _ r) -> r) forms
+-- res1= if null res then Nothing else head res
+-- return $ FormElm [mconcat vs] res1
+
+-- | Concat a list of widgets of the same type, return a the first validated result
+firstOf :: (FormInput view, Monad m, Functor m)=> [View view m a] -> View view m a
firstOf xs= foldl' (<|>) noWidget xs
--- View $ do
--- forms <- mapM runView xs
--- let vs = concatMap (\(FormElm v _) -> [mconcat v]) forms
--- res = filter isJust $ map (\(FormElm _ r) -> r) forms
--- res1= if null res then Nothing else head res
--- return $ FormElm vs res1
-
--- | from a list of widgets, it return the validated ones.
-manyOf :: (FormInput view, MonadIO m, Functor m)=> [View view m a] -> View view m [a]
-manyOf xs= whidden () *> (View $ do
- forms <- mapM runView xs
- let vs = mconcat $ map (\(FormElm v _) -> v) forms
- res1= catMaybes $ map (\(FormElm _ r) -> r) forms
- return . FormElm vs $ Just res1)
+-- View $ do
+-- forms <- mapM runView xs
+-- let vs = concatMap (\(FormElm v _) -> [mconcat v]) forms
+-- res = filter isJust $ map (\(FormElm _ r) -> r) forms
+-- res1= if null res then Nothing else head res
+-- return $ FormElm vs res1
+
+-- | from a list of widgets, it return the validated ones.
+manyOf :: (FormInput view, MonadIO m, Functor m)=> [View view m a] -> View view m [a]
+manyOf xs= whidden () *> (View $ do
+ forms <- mapM runView xs
+ let vs = mconcat $ map (\(FormElm v _) -> v) forms
+ res1= catMaybes $ map (\(FormElm _ r) -> r) forms
+ return . FormElm vs $ Just res1)
-- | like manyOf, but does not validate if one or more of the widgets does not validate
allOf xs= manyOf xs `validate` \rs ->
if length rs== length xs
then return Nothing
else return $ Just mempty
-
-(>:>) :: (Monad m, Monoid v) => View v m a -> View v m [a] -> View v m [a]
-(>:>) w ws = View $ do
- FormElm fs mxs <- runView $ ws
- FormElm f1 mx <- runView w
- return $ FormElm (f1 <> fs)
- $ case( mx,mxs) of
- (Just x, Just xs) -> Just $ x:xs
- (Nothing, mxs) -> mxs
- (Just x, _) -> Just [x]
-
--- | Intersperse a widget in a list of widgets. the results is a 2-tuple of both types.
---
--- it has a infix priority @infixr 5@
-(|*>) :: (MonadIO m, Functor m, FormInput view)
- => View view m r
- -> [View view m r']
- -> View view m (Maybe r,Maybe r')
-(|*>) x xs= View $ do
- fs <- mapM runView xs
- FormElm fx rx <- runView x
+
+(>:>) :: (Monad m, Monoid v) => View v m a -> View v m [a] -> View v m [a]
+(>:>) w ws = View $ do
+ FormElm fs mxs <- runView $ ws
+ FormElm f1 mx <- runView w
+ return $ FormElm (f1 <> fs)
+ $ case( mx,mxs) of
+ (Just x, Just xs) -> Just $ x:xs
+ (Nothing, mxs) -> mxs
+ (Just x, _) -> Just [x]
+
+-- | Intersperse a widget in a list of widgets. the results is a 2-tuple of both types.
+--
+-- it has a infix priority @infixr 5@
+(|*>) :: (MonadIO m, Functor m, FormInput view)
+ => View view m r
+ -> [View view m r']
+ -> View view m (Maybe r,Maybe r')
+(|*>) x xs= View $ do
+ fs <- mapM runView xs
+ FormElm fx rx <- runView x
let (fxs, rxss) = unzip $ map (\(FormElm v r) -> (v,r)) fs
rs= filter isJust rxss
- rxs= if null rs then Nothing else head rs
- return $ FormElm (fx <> mconcat (intersperse fx fxs) <> fx)
- $ case (rx,rxs) of
- (Nothing, Nothing) -> Nothing
- other -> Just other
-
-
-
-infixr 5 |*>
-
--- | Put a widget before and after other. Useful for navigation links in a page that appears at toAdd
--- and at the bottom of a page.
-
--- It has a low infix priority: @infixr 1@
-(|+|) :: (Functor m, FormInput view, MonadIO m)
- => View view m r
- -> View view m r'
- -> View view m (Maybe r, Maybe r')
-(|+|) w w'= w |*> [w']
-
-infixr 1 |+|
-
-
--- | Flatten a binary tree of tuples of Maybe results produced by the \<+> operator
--- into a single tuple with the same elements in the same order.
--- This is useful for easing matching. For example:
---
--- @ res \<- ask $ wlink1 \<+> wlink2 wform \<+> wlink3 \<+> wlink4@
---
--- @res@ has type:
---
--- @Maybe (Maybe (Maybe (Maybe (Maybe a,Maybe b),Maybe c),Maybe d),Maybe e)@
---
--- but @flatten res@ has type:
---
--- @ (Maybe a, Maybe b, Maybe c, Maybe d, Maybe e)@
-
-flatten :: Flatten (Maybe tree) list => tree -> list
-flatten res= doflat $ Just res
-
-class Flatten tree list where
- doflat :: tree -> list
-
-
-type Tuple2 a b= Maybe (Maybe a, Maybe b)
-type Tuple3 a b c= Maybe ( (Tuple2 a b), Maybe c)
-type Tuple4 a b c d= Maybe ( (Tuple3 a b c), Maybe d)
-type Tuple5 a b c d e= Maybe ( (Tuple4 a b c d), Maybe e)
-type Tuple6 a b c d e f= Maybe ( (Tuple5 a b c d e), Maybe f)
-
-instance Flatten (Tuple2 a b) (Maybe a, Maybe b) where
- doflat (Just(ma,mb))= (ma,mb)
- doflat Nothing= (Nothing,Nothing)
-
-instance Flatten (Tuple3 a b c) (Maybe a, Maybe b,Maybe c) where
- doflat (Just(mx,mc))= let(ma,mb)= doflat mx in (ma,mb,mc)
- doflat Nothing= (Nothing,Nothing,Nothing)
-
-instance Flatten (Tuple4 a b c d) (Maybe a, Maybe b,Maybe c,Maybe d) where
- doflat (Just(mx,mc))= let(ma,mb,md)= doflat mx in (ma,mb,md,mc)
- doflat Nothing= (Nothing,Nothing,Nothing,Nothing)
-
-instance Flatten (Tuple5 a b c d e) (Maybe a, Maybe b,Maybe c,Maybe d,Maybe e) where
- doflat (Just(mx,mc))= let(ma,mb,md,me)= doflat mx in (ma,mb,md,me,mc)
- doflat Nothing= (Nothing,Nothing,Nothing,Nothing,Nothing)
-
-instance Flatten (Tuple6 a b c d e f) (Maybe a, Maybe b,Maybe c,Maybe d,Maybe e,Maybe f) where
- doflat (Just(mx,mc))= let(ma,mb,md,me,mf)= doflat mx in (ma,mb,md,me,mf,mc)
- doflat Nothing= (Nothing,Nothing,Nothing,Nothing,Nothing,Nothing)
-
---infixr 7 .<<.
----- | > (.<<.) w x = w $ toByteString x
---(.<<.) :: (FormInput view) => (ByteString -> ByteString) -> view -> ByteString
---(.<<.) w x = w ( toByteString x)
---
----- | > (.<+>.) x y = normalize x <+> normalize y
---(.<+>.)
--- :: (Monad m, FormInput v, FormInput v1) =>
--- View v m a -> View v1 m b -> View ByteString m (Maybe a, Maybe b)
---(.<+>.) x y = normalize x <+> normalize y
---
----- | > (.|*>.) x y = normalize x |*> map normalize y
---(.|*>.)
--- :: (Functor m, MonadIO m, FormInput v, FormInput v1) =>
--- View v m r
--- -> [View v1 m r'] -> View ByteString m (Maybe r, Maybe r')
---(.|*>.) x y = normalize x |*> map normalize y
---
----- | > (.|+|.) x y = normalize x |+| normalize y
---(.|+|.)
--- :: (Functor m, MonadIO m, FormInput v, FormInput v1) =>
--- View v m r -> View v1 m r' -> View ByteString m (Maybe r, Maybe r')
---(.|+|.) x y = normalize x |+| normalize y
---
----- | > (.**>.) x y = normalize x **> normalize y
---(.**>.)
--- :: (Monad m, Functor m, FormInput v, FormInput v1) =>
--- View v m a -> View v1 m b -> View ByteString m b
---(.**>.) x y = normalize x **> normalize y
---
----- | > (.<**.) x y = normalize x <** normalize y
---(.<**.)
--- :: (Monad m, Functor m, FormInput v, FormInput v1) =>
--- View v m a -> View v1 m b -> View ByteString m a
---(.<**.) x y = normalize x <** normalize y
---
----- | > (.<|>.) x y= normalize x <|> normalize y
---(.<|>.)
--- :: (Monad m, Functor m, FormInput v, FormInput v1) =>
--- View v m a -> View v1 m a -> View ByteString m a
---(.<|>.) x y= normalize x <|> normalize y
---
----- | > (.<++.) x v= normalize x <++ toByteString v
---(.<++.) :: (Monad m, FormInput v, FormInput v') => View v m a -> v' -> View ByteString m a
---(.<++.) x v= normalize x <++ toByteString v
---
----- | > (.++>.) v x= toByteString v ++> normalize x
---(.++>.) :: (Monad m, FormInput v, FormInput v') => v -> View v' m a -> View ByteString m a
---(.++>.) v x= toByteString v ++> normalize x
-
-
-instance FormInput ByteString where
- toByteString= id
- toHttpData = HttpData [contentHtml ] []
- ftag x= btag x []
- inred = btag "b" [("style", "color:red")]
- finput n t v f c= btag "input" ([("type", t) ,("name", n),("value", v)] ++ if f then [("checked","true")] else []
- ++ case c of Just s ->[( "onclick", s)]; _ -> [] ) ""
- ftextarea name text= btag "textarea" [("name", name)] $ fromChunks [encodeUtf8 text]
-
- fselect name options= btag "select" [("name", name)] options
-
- foption value content msel= btag "option" ([("value", value)] ++ selected msel) content
- where
- selected msel = if msel then [("selected","true")] else []
-
- attrs = addAttrs
-
-
- formAction action form = btag "form" [("action", action),("method", "post")] form
- fromStr = fromString
- fromStrNoEncode= fromString
-
- flink v str = btag "a" [("href", v)] str
-
------- page Flows ----
-
--- | Prepares the state for a page flow. It add a prefix to every form element or link identifier for the formlets and also
--- keep the state of the links clicked and form imput entered within the widget.
--- If the computation within the widget has branches @if@ @case@ etc, each branch must have its pageFlow with a distinct identifier.
--- See <http://haskell-web.blogspot.com.es/2013/06/the-promising-land-of-monadic-formlets.html>
-pageFlow
- :: (Monad m, Functor m, FormInput view) =>
- String -> View view m a -> View view m a
-pageFlow str widget=do
- s <- get
-
- if mfPageFlow s == False
- then do
- put s{mfPrefix= str ++ mfPrefix s
- ,mfSequence=0
+ rxs= if null rs then Nothing else head rs
+ return $ FormElm (fx <> mconcat (intersperse fx fxs) <> fx)
+ $ case (rx,rxs) of
+ (Nothing, Nothing) -> Nothing
+ other -> Just other
+
+
+
+infixr 5 |*>
+
+-- | Put a widget before and after other. Useful for navigation links in a page that appears at toAdd
+-- and at the bottom of a page.
+
+-- It has a low infix priority: @infixr 1@
+(|+|) :: (Functor m, FormInput view, MonadIO m)
+ => View view m r
+ -> View view m r'
+ -> View view m (Maybe r, Maybe r')
+(|+|) w w'= w |*> [w']
+
+infixr 1 |+|
+
+
+-- | Flatten a binary tree of tuples of Maybe results produced by the \<+> operator
+-- into a single tuple with the same elements in the same order.
+-- This is useful for easing matching. For example:
+--
+-- @ res \<- ask $ wlink1 \<+> wlink2 wform \<+> wlink3 \<+> wlink4@
+--
+-- @res@ has type:
+--
+-- @Maybe (Maybe (Maybe (Maybe (Maybe a,Maybe b),Maybe c),Maybe d),Maybe e)@
+--
+-- but @flatten res@ has type:
+--
+-- @ (Maybe a, Maybe b, Maybe c, Maybe d, Maybe e)@
+
+flatten :: Flatten (Maybe tree) list => tree -> list
+flatten res= doflat $ Just res
+
+class Flatten tree list where
+ doflat :: tree -> list
+
+
+type Tuple2 a b= Maybe (Maybe a, Maybe b)
+type Tuple3 a b c= Maybe ( (Tuple2 a b), Maybe c)
+type Tuple4 a b c d= Maybe ( (Tuple3 a b c), Maybe d)
+type Tuple5 a b c d e= Maybe ( (Tuple4 a b c d), Maybe e)
+type Tuple6 a b c d e f= Maybe ( (Tuple5 a b c d e), Maybe f)
+
+instance Flatten (Tuple2 a b) (Maybe a, Maybe b) where
+ doflat (Just(ma,mb))= (ma,mb)
+ doflat Nothing= (Nothing,Nothing)
+
+instance Flatten (Tuple3 a b c) (Maybe a, Maybe b,Maybe c) where
+ doflat (Just(mx,mc))= let(ma,mb)= doflat mx in (ma,mb,mc)
+ doflat Nothing= (Nothing,Nothing,Nothing)
+
+instance Flatten (Tuple4 a b c d) (Maybe a, Maybe b,Maybe c,Maybe d) where
+ doflat (Just(mx,mc))= let(ma,mb,md)= doflat mx in (ma,mb,md,mc)
+ doflat Nothing= (Nothing,Nothing,Nothing,Nothing)
+
+instance Flatten (Tuple5 a b c d e) (Maybe a, Maybe b,Maybe c,Maybe d,Maybe e) where
+ doflat (Just(mx,mc))= let(ma,mb,md,me)= doflat mx in (ma,mb,md,me,mc)
+ doflat Nothing= (Nothing,Nothing,Nothing,Nothing,Nothing)
+
+instance Flatten (Tuple6 a b c d e f) (Maybe a, Maybe b,Maybe c,Maybe d,Maybe e,Maybe f) where
+ doflat (Just(mx,mc))= let(ma,mb,md,me,mf)= doflat mx in (ma,mb,md,me,mf,mc)
+ doflat Nothing= (Nothing,Nothing,Nothing,Nothing,Nothing,Nothing)
+
+--infixr 7 .<<.
+---- | > (.<<.) w x = w $ toByteString x
+--(.<<.) :: (FormInput view) => (ByteString -> ByteString) -> view -> ByteString
+--(.<<.) w x = w ( toByteString x)
+--
+---- | > (.<+>.) x y = normalize x <+> normalize y
+--(.<+>.)
+-- :: (Monad m, FormInput v, FormInput v1) =>
+-- View v m a -> View v1 m b -> View ByteString m (Maybe a, Maybe b)
+--(.<+>.) x y = normalize x <+> normalize y
+--
+---- | > (.|*>.) x y = normalize x |*> map normalize y
+--(.|*>.)
+-- :: (Functor m, MonadIO m, FormInput v, FormInput v1) =>
+-- View v m r
+-- -> [View v1 m r'] -> View ByteString m (Maybe r, Maybe r')
+--(.|*>.) x y = normalize x |*> map normalize y
+--
+---- | > (.|+|.) x y = normalize x |+| normalize y
+--(.|+|.)
+-- :: (Functor m, MonadIO m, FormInput v, FormInput v1) =>
+-- View v m r -> View v1 m r' -> View ByteString m (Maybe r, Maybe r')
+--(.|+|.) x y = normalize x |+| normalize y
+--
+---- | > (.**>.) x y = normalize x **> normalize y
+--(.**>.)
+-- :: (Monad m, Functor m, FormInput v, FormInput v1) =>
+-- View v m a -> View v1 m b -> View ByteString m b
+--(.**>.) x y = normalize x **> normalize y
+--
+---- | > (.<**.) x y = normalize x <** normalize y
+--(.<**.)
+-- :: (Monad m, Functor m, FormInput v, FormInput v1) =>
+-- View v m a -> View v1 m b -> View ByteString m a
+--(.<**.) x y = normalize x <** normalize y
+--
+---- | > (.<|>.) x y= normalize x <|> normalize y
+--(.<|>.)
+-- :: (Monad m, Functor m, FormInput v, FormInput v1) =>
+-- View v m a -> View v1 m a -> View ByteString m a
+--(.<|>.) x y= normalize x <|> normalize y
+--
+---- | > (.<++.) x v= normalize x <++ toByteString v
+--(.<++.) :: (Monad m, FormInput v, FormInput v') => View v m a -> v' -> View ByteString m a
+--(.<++.) x v= normalize x <++ toByteString v
+--
+---- | > (.++>.) v x= toByteString v ++> normalize x
+--(.++>.) :: (Monad m, FormInput v, FormInput v') => v -> View v' m a -> View ByteString m a
+--(.++>.) v x= toByteString v ++> normalize x
+
+
+instance FormInput ByteString where
+ toByteString= id
+ toHttpData = HttpData [contentHtml ] []
+ ftag x= btag x []
+ inred = btag "b" [("style", "color:red")]
+ finput n t v f c= btag "input" ([("type", t) ,("name", n),("value", v)] ++ if f then [("checked","true")] else []
+ ++ case c of Just s ->[( "onclick", s)]; _ -> [] ) ""
+ ftextarea name text= btag "textarea" [("name", name)] $ fromChunks [encodeUtf8 text]
+
+ fselect name options= btag "select" [("name", name)] options
+
+ foption value content msel= btag "option" ([("value", value)] ++ selected msel) content
+ where
+ selected msel = if msel then [("selected","true")] else []
+
+ attrs = addAttrs
+
+
+ formAction action method form = btag "form" [("action", action),("method", method)] form
+ fromStr = fromString
+ fromStrNoEncode= fromString
+
+ flink v str = btag "a" [("href", v)] str
+
+------ page Flows ----
+
+-- | Prepares the state for a page flow. It add a prefix to every form element or link identifier for the formlets and also
+-- keep the state of the links clicked and form imput entered within the widget.
+-- If the computation within the widget has branches @if@ @case@ etc, each branch must have its pageFlow with a distinct identifier.
+-- See <http://haskell-web.blogspot.com.es/2013/06/the-promising-land-of-monadic-formlets.html>
+pageFlow
+ :: (Monad m, Functor m, FormInput view) =>
+ String -> View view m a -> View view m a
+pageFlow str widget=do
+ s <- get
+
+ if mfPageFlow s == False
+ then do
+ put s{mfPrefix= str ++ mfPrefix s
+ ,mfSequence=0
,mfPageFlow= True
- } -- !> ("PARENT pageflow. prefix="++ str)
-
- r<- widget <** (modify (\s' -> s'{mfSequence= mfSequence s
+ } -- !> ("PARENT pageflow. prefix="++ str)
+
+ r<- widget <** (modify (\s' -> s'{mfSequence= mfSequence s
,mfPrefix= mfPrefix s
- }))
+ }))
modify (\s -> s{mfPageFlow=False} )
- return r -- !> ("END PARENT pageflow. prefix="++ str))
-
-
- else do
- put s{mfPrefix= str++ mfPrefix s,mfSequence=0} -- !> ("PARENT pageflow. prefix="++ str) -- !> ("CHILD pageflow. prefix="++ str)
-
- widget <** (modify (\s' -> s'{mfSequence= mfSequence s
- ,mfPrefix= mfPrefix s}))
- -- !> ("END CHILD pageflow. prefix="++ str))
-
-
-
---acum map []= map
---acum map (x:xs) =
--- let map' = case M.lookup x map of
--- Nothing -> M.insert x 1 map
--- Just n -> M.insert x (n+1) map
--- in acum map' xs
-
+ return r -- !> ("END PARENT pageflow. prefix="++ str))
+
+
+ else do
+ put s{mfPrefix= str++ mfPrefix s,mfSequence=0} -- !> ("PARENT pageflow. prefix="++ str) -- !> ("CHILD pageflow. prefix="++ str)
+
+ widget <** (modify (\s' -> s'{mfSequence= mfSequence s
+ ,mfPrefix= mfPrefix s}))
+ -- !> ("END CHILD pageflow. prefix="++ str))
+
+
+
+--acum map []= map
+--acum map (x:xs) =
+-- let map' = case M.lookup x map of
+-- Nothing -> M.insert x 1 map
+-- Just n -> M.insert x (n+1) map
+-- in acum map' xs
+
diff -ru orig/src/MFlow/Hack/Response.hs new/src/MFlow/Hack/Response.hs
--- orig/src/MFlow/Hack/Response.hs 2014-06-10 05:51:26.969015857 +0300
+++ new/src/MFlow/Hack/Response.hs 2014-06-10 05:51:25.000000000 +0300
@@ -1,13 +1,13 @@
{-# OPTIONS -XExistentialQuantification -XTypeSynonymInstances
- -XFlexibleInstances -XDeriveDataTypeable -XOverloadedStrings #-}
-module MFlow.Hack.Response where
-
+ -XFlexibleInstances -XDeriveDataTypeable -XOverloadedStrings #-}
+module MFlow.Hack.Response where
+
import Hack
-import MFlow.Cookies
+import MFlow.Cookies
import Data.ByteString.Lazy.Char8 as B
-import MFlow
-import Data.Typeable
+import MFlow
+import Data.Typeable
import Data.Monoid
import System.IO.Unsafe
import Data.Map as M
@@ -18,9 +18,9 @@
--(!>)= flip trace
-
-class ToResponse a where
- toResponse :: a -> Response
+
+class ToResponse a where
+ toResponse :: a -> Response
@@ -31,28 +31,28 @@
mappend (TResp x) (TResp y)=
case cast y of
Just y' -> TResp $ mappend x y'
- Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x)
-
+ Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x)
+
instance ToResponse TResp where
- toResponse (TResp x)= toResponse x
+ toResponse (TResp x)= toResponse x
toResponse (TRespR r)= toResponse r
-
-instance ToResponse Response where
- toResponse = id
-
-instance ToResponse ByteString where
- toResponse x= Response{status=200, headers=[contentHtml {-,("Content-Length",show $ B.length x) -}], body= x}
-
-instance ToResponse String where
+
+instance ToResponse Response where
+ toResponse = id
+
+instance ToResponse ByteString where
+ toResponse x= Response{status=200, headers=[contentHtml {-,("Content-Length",show $ B.length x) -}], body= x}
+
+instance ToResponse String where
toResponse x= Response{status=200, headers=[contentHtml{-,("Content-Length",show $ B.length x) -}], body= B.pack x}
instance ToResponse HttpData where
toResponse (HttpData hs cookies x)= (toResponse x) {headers= hs++ cookieHeaders cookies}
- toResponse (Error NotFound str)= Response{status=404, headers=[], body= getNotFoundResponse str}
-
-instance Typeable Env where
- typeOf = \_-> mkTyConApp (mkTyCon3 "hack-handler-simpleserver" "Hack" "Env") []
-
---instance Typeable Response where
--- typeOf = \_-> mkTyConApp (mkTyCon "Hack.Response")[]
+ toResponse (Error NotFound str)= Response{status=404, headers=[], body= getNotFoundResponse str}
+
+instance Typeable Env where
+ typeOf = \_-> mkTyConApp (mkTyCon3 "hack-handler-simpleserver" "Hack" "Env") []
+
+--instance Typeable Response where
+-- typeOf = \_-> mkTyConApp (mkTyCon "Hack.Response")[]
diff -ru orig/src/MFlow/Hack/XHtml.hs new/src/MFlow/Hack/XHtml.hs
--- orig/src/MFlow/Hack/XHtml.hs 2014-06-10 05:51:26.969015857 +0300
+++ new/src/MFlow/Hack/XHtml.hs 2014-06-10 05:51:25.000000000 +0300
@@ -27,14 +27,14 @@
import Text.XHtml
import Data.Typeable
import Data.ByteString.Lazy.Char8 as B(pack,unpack, length, ByteString)
-
-instance ToResponse Html where
+
+instance ToResponse Html where
toResponse x= Response{ status=200, headers=[]
- , Hack.body= pack $ showHtml x}
+ , Hack.body= pack $ showHtml x}
--
---instance Typeable Html where
--- typeOf = \_ -> mkTyConApp (mkTyCon "Text.XHtml.Strict.Html") []
+--instance Typeable Html where
+-- typeOf = \_ -> mkTyConApp (mkTyCon "Text.XHtml.Strict.Html") []
--
---instance ConvertTo Html TResp where
+--instance ConvertTo Html TResp where
-- convert = TResp
diff -ru orig/src/MFlow/Hack.hs new/src/MFlow/Hack.hs
--- orig/src/MFlow/Hack.hs 2014-06-10 05:51:26.957015857 +0300
+++ new/src/MFlow/Hack.hs 2014-06-10 05:51:25.000000000 +0300
@@ -8,33 +8,33 @@
see <http://hackage.haskell.org/package/hack>
-}
-
+
module MFlow.Hack(
module MFlow.Cookies
,module MFlow
,hackMessageFlow)
where
-
-import Data.Typeable
-import Hack
-
-import Control.Concurrent.MVar(modifyMVar_, readMVar)
-import Control.Monad(when)
-
-
-import Data.ByteString.Lazy.Char8 as B(pack, unpack, length, ByteString)
-import Control.Concurrent(ThreadId(..))
-import System.IO.Unsafe
+
+import Data.Typeable
+import Hack
+
+import Control.Concurrent.MVar(modifyMVar_, readMVar)
+import Control.Monad(when)
+
+
+import Data.ByteString.Lazy.Char8 as B(pack, unpack, length, ByteString)
+import Control.Concurrent(ThreadId(..))
+import System.IO.Unsafe
import Control.Concurrent.MVar
-import Control.Concurrent
-import Control.Exception
+import Control.Concurrent
+import Control.Exception
import qualified Data.Map as M
-import Data.Maybe
+import Data.Maybe
import Data.TCache
-import Data.TCache.DefaultPersistence
-import Control.Workflow hiding (Indexable(..))
-
-import MFlow
+import Data.TCache.DefaultPersistence
+import Control.Workflow hiding (Indexable(..))
+
+import MFlow
import MFlow.Cookies
import MFlow.Hack.Response
@@ -46,13 +46,13 @@
flow= "flow"
-
-instance Processable Env where
- pwfname env= if null sc then noScript else sc
- where
+
+instance Processable Env where
+ pwfname env= if null sc then noScript else sc
+ where
sc= tail $ pathInfo env
- puser env = fromMaybe anonymous $ lookup cookieuser $ http env
-
+ puser env = fromMaybe anonymous $ lookup cookieuser $ http env
+
pind env= fromMaybe (error ": No FlowID") $ lookup flow $ http env
getParams= http
-- getServer env= serverName env
@@ -60,38 +60,38 @@
-- getPort env= serverPort env
-
----------------------------------------------
-
-
-
---
---instance ConvertTo String TResp where
--- convert = TResp . pack
+
+---------------------------------------------
+
+
+
--
---instance ConvertTo ByteString TResp where
+--instance ConvertTo String TResp where
+-- convert = TResp . pack
+--
+--instance ConvertTo ByteString TResp where
-- convert = TResp
--
---
---instance ConvertTo Error TResp where
+--
+--instance ConvertTo Error TResp where
-- convert (Error e)= TResp . pack $ errorResponse e
--
--instance ToResponse v =>ConvertTo (HttpData v) TResp where
--- convert= TRespR
+-- convert= TRespR
+
+
+--webScheduler :: Env
+-- -> ProcList
+-- -> IO (TResp, ThreadId)
+--webScheduler = msgScheduler
+
+--theDir= unsafePerformIO getCurrentDirectory
+
+wFMiddleware :: (Env -> Bool) -> (Env-> IO Response) -> (Env -> IO Response)
+wFMiddleware filter f = \ env -> if filter env then hackMessageFlow env else f env -- !> "new message"
-
---webScheduler :: Env
--- -> ProcList
--- -> IO (TResp, ThreadId)
---webScheduler = msgScheduler
-
---theDir= unsafePerformIO getCurrentDirectory
-
-wFMiddleware :: (Env -> Bool) -> (Env-> IO Response) -> (Env -> IO Response)
-wFMiddleware filter f = \ env -> if filter env then hackMessageFlow env else f env -- !> "new message"
-
-- | An instance of the abstract "MFlow" scheduler to the Hack interface
--- it accept the list of processes being scheduled and return a hack handler
+-- it accept the list of processes being scheduled and return a hack handler
--
-- Example:
--
@@ -107,112 +107,112 @@
-- concat [ "http:\/\/server\/"++ i ++ "\n" | (i,_) \<- msgs]
-- @
--hackMessageFlow :: [(String, (Token -> Workflow IO ()))]
--- -> (Env -> IO Response)
---hackMessageFlow messageFlows =
--- unsafePerformIO (addMessageFlows messageFlows) `seq`
--- hackWorkflow -- wFMiddleware f other
+-- -> (Env -> IO Response)
+--hackMessageFlow messageFlows =
+-- unsafePerformIO (addMessageFlows messageFlows) `seq`
+-- hackWorkflow -- wFMiddleware f other
-- where
-- f env = unsafePerformIO $ do
-- paths <- getMessageFlows >>=
-- return (pwfname env `elem` paths)
--- other= (\env -> defaultResponse $ "options: " ++ opts)
+-- other= (\env -> defaultResponse $ "options: " ++ opts)
-- (paths,_)= unzip messageFlows
-- opts= concatMap (\s -> "<a href=\""++ s ++"\">"++s ++"</a>, ") paths
-
-
-splitPath ""= ("","","")
-splitPath str=
- let
- strr= reverse str
- (ext, rest)= span (/= '.') strr
- (mod, path)= span(/='/') $ tail rest
- in (tail $ reverse path, reverse mod, reverse ext)
-
-
-
-hackMessageFlow :: Env -> IO Response
-hackMessageFlow req1= do
- let httpreq1= http req1
- let cookies= {-# SCC "getCookies" #-} getCookies httpreq1
-
- (flowval , retcookies) <- case lookup ( flow) cookies of
- Just fl -> return (fl, [])
- Nothing -> do
- fl <- newFlow
+
+
+splitPath ""= ("","","")
+splitPath str=
+ let
+ strr= reverse str
+ (ext, rest)= span (/= '.') strr
+ (mod, path)= span(/='/') $ tail rest
+ in (tail $ reverse path, reverse mod, reverse ext)
+
+
+
+hackMessageFlow :: Env -> IO Response
+hackMessageFlow req1= do
+ let httpreq1= http req1
+ let cookies= {-# SCC "getCookies" #-} getCookies httpreq1
+
+ (flowval , retcookies) <- case lookup ( flow) cookies of
+ Just fl -> return (fl, [])
+ Nothing -> do
+ fl <- newFlow
return ( fl, [( flow, fl, "/",(Just $ show $ 365*24*60*60))])
-
-{- for state persistence in cookies
- putStateCookie req1 cookies
- let retcookies= case getStateCookie req1 of
- Nothing -> retcookies1
- Just ck -> ck:retcookies1
--}
-
- let input=
- case ( requestMethod req1, lookup "Content-Type" httpreq1 ) of
- (POST,Just "application/x-www-form-urlencoded") -> urlDecode . unpack $ hackInput req1
- (GET, _) -> urlDecode . queryString $ req1
- _ -> []
-
- let req = case retcookies of
- [] -> req1{http= (input ++ cookies) ++ http req1} -- !> "REQ"
- _ -> req1{http=(flow, flowval): ( input ++ cookies ) ++ http req1} -- !> "REQ"
-
-
+
+{- for state persistence in cookies
+ putStateCookie req1 cookies
+ let retcookies= case getStateCookie req1 of
+ Nothing -> retcookies1
+ Just ck -> ck:retcookies1
+-}
+
+ let input=
+ case ( requestMethod req1, lookup "Content-Type" httpreq1 ) of
+ (POST,Just "application/x-www-form-urlencoded") -> urlDecode . unpack $ hackInput req1
+ (GET, _) -> urlDecode . queryString $ req1
+ _ -> []
+
+ let req = case retcookies of
+ [] -> req1{http= (input ++ cookies) ++ http req1} -- !> "REQ"
+ _ -> req1{http=(flow, flowval): ( input ++ cookies ) ++ http req1} -- !> "REQ"
+
+
(resp',th) <- msgScheduler req
-
- let resp''= toResponse resp'
+
+ let resp''= toResponse resp'
let headers1= case retcookies of [] -> headers resp''; _ -> (cookieHeaders retcookies)
- let resp = resp''{status=200, headers= headers1 {-,("Content-Length",show $ B.length x) -}}
-
+ let resp = resp''{status=200, headers= headers1 {-,("Content-Length",show $ B.length x) -}}
+
return resp
-
-------persistent state in cookies (not tested)
-
-tvresources :: MVar (Maybe ( M.Map string string))
-tvresources= unsafePerformIO $ newMVar Nothing
-statCookieName= "stat"
-
-putStateCookie req cookies=
- case lookup statCookieName cookies of
- Nothing -> return ()
- Just (statCookieName, str , "/", _) -> modifyMVar_ tvresources $
- \mmap -> case mmap of
- Just map -> return $ Just $ M.insert (keyResource req) str map
- Nothing -> return $ Just $ M.fromList [((keyResource req), str) ]
-
-getStateCookie req= do
- mr<- readMVar tvresources
- case mr of
- Nothing -> return Nothing
- Just map -> case M.lookup (keyResource req) map of
- Nothing -> return Nothing
- Just str -> do
- swapMVar tvresources Nothing
- return $ Just (statCookieName, str , "/")
-
-{-
-persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource}
- where
- writeResource stat= modifyMVar_ tvresources $ \mmap ->
- case mmap of
- Just map-> return $ Just $ M.insert (keyResource stat) (serialize stat) map
- Nothing -> return $ Just $ M.fromList [((keyResource stat), (serialize stat)) ]
- readResource stat= do
- mstr <- withMVar tvresources $ \mmap ->
- case mmap of
- Just map -> return $ M.lookup (keyResource stat) map
- Nothing -> return Nothing
- case mstr of
- Nothing -> return Nothing
- Just str -> return $ deserialize str
-
- deleteResource stat= modifyMVar_ tvresources $ \mmap->
- case mmap of
- Just map -> return $ Just $ M.delete (keyResource stat) map
- Nothing -> return $ Nothing
+
+------persistent state in cookies (not tested)
+
+tvresources :: MVar (Maybe ( M.Map string string))
+tvresources= unsafePerformIO $ newMVar Nothing
+statCookieName= "stat"
+
+putStateCookie req cookies=
+ case lookup statCookieName cookies of
+ Nothing -> return ()
+ Just (statCookieName, str , "/", _) -> modifyMVar_ tvresources $
+ \mmap -> case mmap of
+ Just map -> return $ Just $ M.insert (keyResource req) str map
+ Nothing -> return $ Just $ M.fromList [((keyResource req), str) ]
+
+getStateCookie req= do
+ mr<- readMVar tvresources
+ case mr of
+ Nothing -> return Nothing
+ Just map -> case M.lookup (keyResource req) map of
+ Nothing -> return Nothing
+ Just str -> do
+ swapMVar tvresources Nothing
+ return $ Just (statCookieName, str , "/")
+
+{-
+persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource}
+ where
+ writeResource stat= modifyMVar_ tvresources $ \mmap ->
+ case mmap of
+ Just map-> return $ Just $ M.insert (keyResource stat) (serialize stat) map
+ Nothing -> return $ Just $ M.fromList [((keyResource stat), (serialize stat)) ]
+ readResource stat= do
+ mstr <- withMVar tvresources $ \mmap ->
+ case mmap of
+ Just map -> return $ M.lookup (keyResource stat) map
+ Nothing -> return Nothing
+ case mstr of
+ Nothing -> return Nothing
+ Just str -> return $ deserialize str
+
+ deleteResource stat= modifyMVar_ tvresources $ \mmap->
+ case mmap of
+ Just map -> return $ Just $ M.delete (keyResource stat) map
+ Nothing -> return $ Nothing
-}
diff -ru orig/src/MFlow/Wai/Blaze/Html/All.hs new/src/MFlow/Wai/Blaze/Html/All.hs
--- orig/src/MFlow/Wai/Blaze/Html/All.hs 2014-06-10 05:51:26.969015857 +0300
+++ new/src/MFlow/Wai/Blaze/Html/All.hs 2014-06-10 05:51:25.000000000 +0300
@@ -1,97 +1,99 @@
-----------------------------------------------------------------------------
---
--- Module : MFlow.Wai.Blaze.Html.All
--- Copyright :
--- License : BSD3
---
--- Maintainer : agocorona@gmail.com
--- Stability : experimental
--- Portability :
---
--- |
---
------------------------------------------------------------------------------
-
-module MFlow.Wai.Blaze.Html.All (
- module Data.TCache
-,module MFlow
-,module MFlow.Forms
-,module MFlow.Forms.Widgets
-,module MFlow.Forms.Blaze.Html
-,module MFlow.Forms.Admin
-,module Control.Applicative
-,module Text.Blaze.Html5
-,module Text.Blaze.Html5.Attributes
-,module Control.Monad.IO.Class
-,module MFlow.Forms.WebApi
-,module MFlow.Forms.Cache
-,runNavigation
-,runSecureNavigation
-) where
-
-import MFlow
-import MFlow.Wai
-import MFlow.Forms
-import MFlow.Forms.Widgets
-import MFlow.Forms.Admin
-import MFlow.Forms.Blaze.Html
-import MFlow.Forms.WebApi
-import MFlow.Forms.Cache
-import Text.Blaze.Html5 hiding (map)
-import Text.Blaze.Html5.Attributes hiding (label,span,style,cite,title,summary,step,form)
-import Network.Wai
-import Network.Wai.Handler.Warp hiding (getPort) --(run,defaultSettings,Settings ,setPort)
-import Data.TCache
-import Text.Blaze.Internal(text)
-
-import Control.Workflow (Workflow, unsafeIOtoWF)
-
-
-import Control.Applicative
-import Control.Monad(when, unless)
-import Control.Monad.IO.Class
-import System.Environment
-import Data.Maybe(fromMaybe)
-import Data.Char(isNumber)
-import Network.Wai.Handler.WarpTLS as TLS
-
--- | The port is read from the first exectution parameter.
--- If no parameter, it is read from the PORT environment variable.
--- if this does not exist, the port 80 is used.
-getPort= do
- args <- getArgs
- port <- case args of
- port:xs -> return port
- _ -> do
- env <- getEnvironment
- return $ fromMaybe "80" $ lookup "PORT" env
- let porti= if and $ map isNumber port then fromIntegral $ read port
- else 80
- putStr "using port "
- print porti
- return porti
-
--- | run a persistent flow. It uses `getPort` to get the port
--- The first parameter is the first element in the URL path.
--- It also set the home page
-runNavigation :: String -> FlowM Html (Workflow IO) () -> IO ()
-runNavigation n f= do
- unless (null n) $ setNoScript n
- addMessageFlows[(n, runFlow f)]
- porti <- getPort
- wait $ run porti waiMessageFlow
- --runSettings defaultSettings{settingsTimeout = 20, settingsPort= porti} waiMessageFlow
-
--- | Exactly the same as runNavigation, but with TLS added.
--- Expects certificate.pem and key.pem in project directory.
-
-runSecureNavigation = runSecureNavigation' TLS.defaultTlsSettings defaultSettings
-
-runSecureNavigation' :: TLSSettings -> Settings -> String -> FlowM Html (Workflow IO) () -> IO ()
-runSecureNavigation' t s n f = do
- unless (null n) $ setNoScript n
- addMessageFlows[(n, runFlow f)]
- porti <- getPort
--- let s' = setPort porti s
+----------------------------------------------------------------------------
+--
+-- Module : MFlow.Wai.Blaze.Html.All
+-- Copyright :
+-- License : BSD3
+--
+-- Maintainer : agocorona@gmail.com
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module MFlow.Wai.Blaze.Html.All (
+ module Data.TCache
+,module MFlow
+,module MFlow.Forms
+,module MFlow.Forms.Widgets
+,module MFlow.Forms.Blaze.Html
+,module MFlow.Forms.Admin
+,module Control.Applicative
+,module Text.Blaze.Html5
+,module Text.Blaze.Html5.Attributes
+,module Control.Monad.IO.Class
+,module MFlow.Forms.WebApi
+,module MFlow.Forms.Cache
+,runNavigation
+,runSecureNavigation
+,runSecureNavigation'
+) where
+
+import MFlow
+import MFlow.Wai
+import MFlow.Forms
+import MFlow.Forms.Widgets
+import MFlow.Forms.Admin
+import MFlow.Forms.Blaze.Html
+import MFlow.Forms.WebApi
+import MFlow.Forms.Cache
+import Text.Blaze.Html5 hiding (map)
+import Text.Blaze.Html5.Attributes hiding (label,span,style,cite,title,summary,step,form)
+import Network.Wai
+import Network.Wai.Handler.Warp --(run,defaultSettings,Settings ,setPort)
+import Data.TCache
+import Text.Blaze.Internal(text)
+
+import Control.Workflow (Workflow, unsafeIOtoWF)
+
+
+import Control.Applicative
+import Control.Monad(when, unless)
+import Control.Monad.IO.Class
+import System.Environment
+import Data.Maybe(fromMaybe)
+import Data.Char(isNumber)
+import Network.Wai.Handler.WarpTLS as TLS
+
+
+getPortW= do
+ args <- getArgs
+ port <- case args of
+ port:xs -> return port
+ _ -> do
+ env <- getEnvironment
+ return $ fromMaybe "80" $ lookup "PORT" env
+ let porti= if and $ map isNumber port then fromIntegral $ read port
+ else 80
+ putStr "using port "
+ print porti
+ return porti
+
+-- | run a persistent flow. It uses `getPortW` to get the port
+-- The first parameter is the first element in the URL path.
+-- It also set the home page
+-- The port is read from the first parameter passed to the executable.
+-- If no parameter, it is read from the PORT environment variable.
+-- if this does not exist, the port 80 is used.
+runNavigation :: String -> FlowM Html (Workflow IO) () -> IO ()
+runNavigation n f= do
+ unless (null n) $ setNoScript n
+ addMessageFlows[(n, runFlow f)]
+ porti <- getPortW
+ wait $ run porti waiMessageFlow
+ --runSettings defaultSettings{settingsTimeout = 20, settingsPort= porti} waiMessageFlow
+
+-- | Exactly the same as runNavigation, but with TLS added.
+-- Expects certificate.pem and key.pem in project directory.
+
+runSecureNavigation = runSecureNavigation' TLS.defaultTlsSettings defaultSettings
+
+runSecureNavigation' :: TLSSettings -> Settings -> String -> FlowM Html (Workflow IO) () -> IO ()
+runSecureNavigation' t s n f = do
+ unless (null n) $ setNoScript n
+ addMessageFlows[(n, runFlow f)]
+ porti <- getPortW
+-- let s' = setPort porti s
-- wait $ TLS.runTLS t s' waiMessageFlow
- wait $ TLS.runTLS t s{settingsPort = porti} waiMessageFlow
+ wait $ TLS.runTLS t s{settingsPort = porti} waiMessageFlow
diff -ru orig/src/MFlow/Wai/Response.hs new/src/MFlow/Wai/Response.hs
--- orig/src/MFlow/Wai/Response.hs 2014-06-10 05:51:26.965015857 +0300
+++ new/src/MFlow/Wai/Response.hs 2014-06-10 05:51:25.000000000 +0300
@@ -1,62 +1,62 @@
-{-# OPTIONS -XExistentialQuantification -XTypeSynonymInstances
- -XFlexibleInstances -XDeriveDataTypeable -XOverloadedStrings #-}
-module MFlow.Wai.Response where
-
-import Network.Wai
-import MFlow.Cookies
-
-import Data.ByteString.Lazy.UTF8
-import MFlow
-import Data.Typeable
-import Data.Monoid
-import System.IO.Unsafe
-import Data.Map as M
-import Data.CaseInsensitive
-import Network.HTTP.Types
-import Control.Workflow(WFErrors(..))
---import Data.String
---import Debug.Trace
---
---(!>)= flip trace
-
-
-
-class ToResponse a where
- toResponse :: a -> Response
-
-
-
-data TResp = TRempty | forall a.ToResponse a=>TRespR a | forall a.(Typeable a, ToResponse a, Monoid a) => TResp a deriving Typeable
-
-instance Monoid TResp where
- mempty = TRempty
- mappend (TResp x) (TResp y)=
- case cast y of
- Just y' -> TResp $ mappend x y'
- Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x)
-
-
-mkParams = Prelude.map mkparam
-mkparam (x,y)= (mk x, y)
-
-instance ToResponse TResp where
- toResponse (TResp x)= toResponse x
- toResponse (TRespR r)= toResponse r
-
-instance ToResponse Response where
- toResponse = id
-
-instance ToResponse ByteString where
- toResponse x= responseLBS status200 [mkparam contentHtml] x
-
-instance ToResponse String where
- toResponse x= responseLBS status200 [mkparam contentHtml] $ fromString x
-
-instance ToResponse HttpData where
- toResponse (HttpData hs cookies x)= responseLBS status200 (mkParams ( hs <> cookieHeaders cookies)) x
- toResponse (Error str)= responseLBS status404 [("Content-Type", "text/html")] str
-
--- toResponse $ error "FATAL ERROR: HttpData errors should not reach here: MFlow.Forms.Response.hs "
-
-
-
+{-# OPTIONS -XExistentialQuantification -XTypeSynonymInstances
+ -XFlexibleInstances -XDeriveDataTypeable -XOverloadedStrings #-}
+module MFlow.Wai.Response where
+
+import Network.Wai
+import MFlow.Cookies
+
+import Data.ByteString.Lazy.UTF8
+import MFlow
+import Data.Typeable
+import Data.Monoid
+import System.IO.Unsafe
+import Data.Map as M
+import Data.CaseInsensitive
+import Network.HTTP.Types
+import Control.Workflow(WFErrors(..))
+--import Data.String
+--import Debug.Trace
+--
+--(!>)= flip trace
+
+
+
+class ToResponse a where
+ toResponse :: a -> Response
+
+
+
+data TResp = TRempty | forall a.ToResponse a=>TRespR a | forall a.(Typeable a, ToResponse a, Monoid a) => TResp a deriving Typeable
+
+instance Monoid TResp where
+ mempty = TRempty
+ mappend (TResp x) (TResp y)=
+ case cast y of
+ Just y' -> TResp $ mappend x y'
+ Nothing -> error $ "fragment of type " ++ show ( typeOf y) ++ " after fragment of type " ++ show ( typeOf x)
+
+
+mkParams = Prelude.map mkparam
+mkparam (x,y)= (mk x, y)
+
+instance ToResponse TResp where
+ toResponse (TResp x)= toResponse x
+ toResponse (TRespR r)= toResponse r
+
+instance ToResponse Response where
+ toResponse = id
+
+instance ToResponse ByteString where
+ toResponse x= responseLBS status200 [mkparam contentHtml] x
+
+instance ToResponse String where
+ toResponse x= responseLBS status200 [mkparam contentHtml] $ fromString x
+
+instance ToResponse HttpData where
+ toResponse (HttpData hs cookies x)= responseLBS status200 (mkParams ( hs <> cookieHeaders cookies)) x
+ toResponse (Error str)= responseLBS status404 [("Content-Type", "text/html")] str
+
+-- toResponse $ error "FATAL ERROR: HttpData errors should not reach here: MFlow.Forms.Response.hs "
+
+
+
diff -ru orig/src/MFlow/Wai.hs new/src/MFlow/Wai.hs
--- orig/src/MFlow/Wai.hs 2014-06-10 05:51:26.957015857 +0300
+++ new/src/MFlow/Wai.hs 2014-06-10 05:51:25.000000000 +0300
@@ -1,184 +1,209 @@
-{-# LANGUAGE UndecidableInstances
- , CPP
- , TypeSynonymInstances
- , MultiParamTypeClasses
- , DeriveDataTypeable
- , FlexibleInstances
- , OverloadedStrings #-}
-
-module MFlow.Wai(
- module MFlow.Cookies
- ,module MFlow
- ,waiMessageFlow)
-where
-
-import Data.Typeable
-import Network.Wai
-
-import Control.Concurrent.MVar(modifyMVar_, readMVar)
-import Control.Monad(when)
-
-
-import qualified Data.ByteString.Lazy.Char8 as B(empty,pack, unpack, length, ByteString,tail)
-import Data.ByteString.Lazy(fromChunks)
+{-# LANGUAGE UndecidableInstances
+ , CPP
+ , TypeSynonymInstances
+ , MultiParamTypeClasses
+ , DeriveDataTypeable
+ , FlexibleInstances
+ , OverloadedStrings #-}
+
+module MFlow.Wai(
+ module MFlow.Cookies
+ ,module MFlow
+ ,waiMessageFlow)
+where
+
+import Data.Typeable
+import Network.Wai
+
+import Control.Concurrent.MVar(modifyMVar_, readMVar)
+import Control.Monad(when)
+
+
+import qualified Data.ByteString.Lazy.Char8 as B(empty,pack, unpack, length, ByteString,tail)
+import Data.ByteString.Lazy(fromChunks)
import Data.ByteString.UTF8 hiding (span)
-import qualified Data.ByteString as SB hiding (pack, unpack)
-import Control.Concurrent(ThreadId(..))
-import System.IO.Unsafe
-import Control.Concurrent.MVar
-import Control.Concurrent
-import Control.Monad.Trans
-import Control.Exception
-import qualified Data.Map as M
-import Data.Maybe
-import Data.TCache
-import Data.TCache.DefaultPersistence
-import Control.Workflow hiding (Indexable(..))
-
-import MFlow
-import MFlow.Cookies
-import Data.Monoid
-import MFlow.Wai.Response
-import Network.Wai
-import Network.HTTP.Types -- hiding (urlDecode)
-import Data.Conduit
-import Data.Conduit.Lazy
-import qualified Data.Conduit.List as CList
-import Data.CaseInsensitive
-import System.Time
-import qualified Data.Text as T
-
-
---import Debug.Trace
---(!>) = flip trace
-
-flow= "flow"
-
-instance Processable Request where
- pwfPath env= if Prelude.null sc then [noScript] else Prelude.map T.unpack sc
- where
- sc= let p= pathInfo env
- p'= reverse p
- in case p' of
- [] -> []
- p' -> if T.null $ head p' then reverse(tail p') else p
-
-
- puser env = fromMaybe anonymous $ fmap toString $ lookup ( mk $ fromString cookieuser) $ requestHeaders env
-
- pind env= fromMaybe (error ": No FlowID") $ fmap toString $ lookup (mk flow) $ requestHeaders env
- getParams= mkParams1 . requestHeaders
- where
- mkParams1 = Prelude.map mkParam1
- mkParam1 ( x,y)= (toString $ original x, toString y)
-
--- getServer env= serverName env
--- getPath env= pathInfo env
--- getPort env= serverPort env
-
-
-splitPath ""= ("","","")
-splitPath str=
- let
- strr= reverse str
- (ext, rest)= span (/= '.') strr
- (mod, path)= span(/='/') $ tail rest
- in (tail $ reverse path, reverse mod, reverse ext)
-
-
-waiMessageFlow :: Application
-waiMessageFlow req1= do
- let httpreq1= requestHeaders req1
-
- let cookies = getCookies httpreq1
-
- (flowval , retcookies) <- case lookup flow cookies of
- Just fl -> return (fl, [])
- Nothing -> do
- fl <- liftIO $ newFlow
- return (fl, [UnEncryptedCookie (flow, fl, "/",Nothing):: Cookie])
-
-{- for state persistence in cookies
- putStateCookie req1 cookies
- let retcookies= case getStateCookie req1 of
- Nothing -> retcookies1
- Just ck -> ck:retcookies1
--}
-
- input <- case parseMethod $ requestMethod req1 of
- Right POST -> do
-
- inp <- liftIO $ requestBody req1 $$ CList.consume
-
- return . parseSimpleQuery $ SB.concat inp
-
-
-
- Right GET ->
- return . Prelude.map (\(x,y) -> (x,fromMaybe "" y)) $ queryString req1
-
-
- let req = case retcookies of
- [] -> req1{requestHeaders= mkParams (input ++ cookies) ++ requestHeaders req1} -- !> "REQ"
- _ -> req1{requestHeaders= mkParams ((flow, flowval): input ++ cookies) ++ requestHeaders req1} -- !> "REQ"
-
-
- (resp',th) <- liftIO $ msgScheduler req -- !> (show $ requestHeaders req)
-
- let resp= case (resp',retcookies) of
- (_,[]) -> resp'
- (error@(Error _),_) -> error
- (HttpData hs co str,_) -> HttpData hs (co++ retcookies) str
-
- return $ toResponse resp
-
-
-------persistent state in cookies (not tested)
-
-tvresources :: MVar (Maybe ( M.Map string string))
-tvresources= unsafePerformIO $ newMVar Nothing
-statCookieName= "stat"
-
-putStateCookie req cookies=
- case lookup statCookieName cookies of
- Nothing -> return ()
- Just (statCookieName, str , "/", _) -> modifyMVar_ tvresources $
- \mmap -> case mmap of
- Just map -> return $ Just $ M.insert (keyResource req) str map
- Nothing -> return $ Just $ M.fromList [((keyResource req), str) ]
-
-getStateCookie req= do
- mr<- readMVar tvresources
- case mr of
- Nothing -> return Nothing
- Just map -> case M.lookup (keyResource req) map of
- Nothing -> return Nothing
- Just str -> do
- swapMVar tvresources Nothing
- return $ Just (statCookieName, str , "/")
-
-
-
-
-{-
-persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource}
- where
- writeResource stat= modifyMVar_ tvresources $ \mmap ->
- case mmap of
- Just map-> return $ Just $ M.insert (keyResource stat) (serialize stat) map
- Nothing -> return $ Just $ M.fromList [((keyResource stat), (serialize stat)) ]
- readResource stat= do
- mstr <- withMVar tvresources $ \mmap ->
- case mmap of
- Just map -> return $ M.lookup (keyResource stat) map
- Nothing -> return Nothing
- case mstr of
- Nothing -> return Nothing
- Just str -> return $ deserialize str
-
- deleteResource stat= modifyMVar_ tvresources $ \mmap->
- case mmap of
- Just map -> return $ Just $ M.delete (keyResource stat) map
- Nothing -> return $ Nothing
-
--}
+import qualified Data.ByteString.Char8 as SB -- hiding (pack, unpack)
+import Control.Concurrent(ThreadId(..))
+import System.IO.Unsafe
+import Control.Concurrent.MVar
+import Control.Concurrent
+import Control.Monad.Trans
+import Control.Exception
+import qualified Data.Map as M
+import Data.Maybe
+import Data.TCache
+import Data.TCache.DefaultPersistence
+import Control.Workflow hiding (Indexable(..))
+
+import MFlow
+import MFlow.Cookies
+import Data.Monoid
+import MFlow.Wai.Response
+import Network.Wai
+import Network.Wai.Parse
+import qualified Data.Conduit.Binary as CB
+import Control.Monad.Trans.Resource
+import Network.HTTP.Types
+import Data.Conduit
+import Data.Conduit.Lazy
+import qualified Data.Conduit.List as CList
+import Data.CaseInsensitive
+import System.Time
+import System.Directory
+import System.IO
+import qualified Data.Text as T
+
+
+import Debug.Trace
+(!>) = flip trace
+
+flow= "flow"
+
+instance Processable Request where
+ pwfPath env= if Prelude.null sc then [noScript] else Prelude.map T.unpack sc
+ where
+ sc= let p= pathInfo env
+ p'= reverse p
+ in case p' of
+ [] -> []
+ p' -> if T.null $ head p' then reverse(tail p') else p
+
+
+ puser env = fromMaybe anonymous $ fmap toString $ lookup ( mk $ fromString cookieuser) $ requestHeaders env
+
+ pind env= fromMaybe (error ": No FlowID") $ fmap toString $ lookup (mk flow) $ requestHeaders env
+ getParams= mkParams1 . requestHeaders
+ where
+ mkParams1 = Prelude.map mkParam1
+ mkParam1 ( x,y)= (toString $ original x, toString y)
+
+toApp :: (Request -> IO Response) -> Application
+#if MIN_VERSION_wai(3, 0, 0)
+toApp f req sendResponse = f req >>= sendResponse
+#else
+toApp = id
+#endif
+
+waiMessageFlow :: Application
+waiMessageFlow = toApp $ \req1 -> do
+ let httpreq1= requestHeaders req1
+
+ let cookies = getCookies httpreq1
+
+ (flowval , retcookies) <- case lookup flow cookies of
+ Just fl -> return (fl, [])
+ Nothing -> do
+ fl <- liftIO $ newFlow
+ return (fl, [UnEncryptedCookie (flow, fl, "/",Nothing):: Cookie])
+
+{- for state persistence in cookies
+ putStateCookie req1 cookies
+ let retcookies= case getStateCookie req1 of
+ Nothing -> retcookies1
+ Just ck -> ck:retcookies1
+-}
+
+ (params,files) <- case parseMethod $ requestMethod req1 of
+ Right GET -> do
+ return (Prelude.map (\(x,y) -> (x,fromMaybe "" y)) $ queryString req1,[])
+
+ Right POST -> do
+
+ case getRequestBodyType req1 of
+ Nothing -> error $ "getRequestBodyType: "
+ Just rbt ->
+ runResourceT $ withInternalState $ \state -> liftIO $ do
+ let backend file info= do
+ (key, (fp, h)) <- flip runInternalState state $ allocate (do
+ tempDir <- getTemporaryDirectory
+ openBinaryTempFile tempDir "upload.tmp") (\(_, h) -> hClose h)
+ CB.sinkHandle h
+ lift $ release key
+ return fp
+#if MIN_VERSION_wai(3, 0, 0)
+ let backend' file info getBS = do
+ let src = do
+ bs <- liftIO getBS
+ when (not $ SB.null bs) $ do
+ Data.Conduit.yield bs
+ src
+ src $$ backend file info
+ sinkRequestBody backend' rbt (requestBody req1)
+#else
+ requestBody req1 $$ sinkRequestBody backend rbt
+#endif
+
+-- let fileparams= Prelude.map (\(param,FileInfo filename contentype content)
+-- -> (param, SB.pack content )) files
+-- let fileparams= Prelude.map (\(param,fileinfo)
+-- -> (param, fileinfo )) files
+-- return $ fileparams++ params
+ let filesp= Prelude.map (\(param,FileInfo filename contentype tempfile)
+ -> (mk param, fromString $ show(filename,contentype,tempfile) )) files
+-- let filesp= Prelude.map (\(a,b) -> ( mk a, fromString $ show b)) files
+
+
+ let req = case retcookies of
+ [] -> req1{requestHeaders= filesp ++ mkParams (params ++ cookies) ++ requestHeaders req1}
+ _ -> req1{requestHeaders= filesp ++ mkParams ((flow, flowval): params ++ cookies) ++ requestHeaders req1}
+
+
+ (resp',th) <- liftIO $ msgScheduler req -- !> (show $ requestHeaders req)
+
+ let resp= case (resp',retcookies) of
+ (_,[]) -> resp'
+ (error@(Error _),_) -> error
+ (HttpData hs co str,_) -> HttpData hs (co++ retcookies) str
+
+ return $ toResponse resp
+
+
+------persistent state in cookies (not tested)
+
+tvresources :: MVar (Maybe ( M.Map string string))
+tvresources= unsafePerformIO $ newMVar Nothing
+statCookieName= "stat"
+
+putStateCookie req cookies=
+ case lookup statCookieName cookies of
+ Nothing -> return ()
+ Just (statCookieName, str , "/", _) -> modifyMVar_ tvresources $
+ \mmap -> case mmap of
+ Just map -> return $ Just $ M.insert (keyResource req) str map
+ Nothing -> return $ Just $ M.fromList [((keyResource req), str) ]
+
+getStateCookie req= do
+ mr<- readMVar tvresources
+ case mr of
+ Nothing -> return Nothing
+ Just map -> case M.lookup (keyResource req) map of
+ Nothing -> return Nothing
+ Just str -> do
+ swapMVar tvresources Nothing
+ return $ Just (statCookieName, str , "/")
+
+
+
+
+{-
+persistInCookies= setPersist PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource}
+ where
+ writeResource stat= modifyMVar_ tvresources $ \mmap ->
+ case mmap of
+ Just map-> return $ Just $ M.insert (keyResource stat) (serialize stat) map
+ Nothing -> return $ Just $ M.fromList [((keyResource stat), (serialize stat)) ]
+ readResource stat= do
+ mstr <- withMVar tvresources $ \mmap ->
+ case mmap of
+ Just map -> return $ M.lookup (keyResource stat) map
+ Nothing -> return Nothing
+ case mstr of
+ Nothing -> return Nothing
+ Just str -> return $ deserialize str
+
+ deleteResource stat= modifyMVar_ tvresources $ \mmap->
+ case mmap of
+ Just map -> return $ Just $ M.delete (keyResource stat) map
+ Nothing -> return $ Nothing
+
+-}
diff -ru orig/src/MFlow.hs new/src/MFlow.hs
--- orig/src/MFlow.hs 2014-06-10 05:51:26.957015857 +0300
+++ new/src/MFlow.hs 2014-06-10 05:51:25.000000000 +0300
@@ -1,545 +1,550 @@
-{- | Non monadic low level primitives that implement the MFlow application server.
-See "MFlow.Form" for the higher level interface that you may use.
-
-it implements an scheduler of 'Processable' messages that are served according with
-the source identification and the verb invoked.
-The scheduler executed the appropriate workflow (using the workflow package).
-The workflow will send additional messages to the source and wait for the responses.
-The diaglog is identified by a 'Token', which is associated to the flow.
-. The computation state is optionally logged. On timeout, the process is killed. When invoked again,
-the execution state is recovered as if no interruption took place.
-
-There is no asumption about message codification, so instantiations
-of this scheduler for different infrastructures is possible,
-including non-Web based ones as long as they support or emulate cookies.
-
-"MFlow.Hack" is an instantiation for the Hack interface in a Web context.
-
-"MFlow.Wai" is a instantiation for the WAI interface.
-
-"MFlow.Forms" implements a monadic type safe interface with composabe widgets and and applicative
-combinator as well as an higher comunication interface.
-
-"MFlow.Forms.XHtml" is an instantiation for the Text.XHtml format
-
-"MFlow.Forms.Blaze.Html" is an instantaiation for blaze-html
-
-"MFlow.Forms.HSP" is an instantiation for the Haskell Server Pages format
-
-There are some @*.All@ packages that contain a mix of these instantiations.
-For exmaple, "MFlow.Wai.Blaze.Html.All" includes most of all necessary for using MFlow with
-Wai <http://hackage.haskell.org/package/wai> and
-Blaze-html <http://hackage.haskell.org/package/blaze-html>
-
-
-In order to manage resources, there are primitives that kill the process and its state after a timeout.
-
-All these details are hidden in the monad of "MFlow.Forms" that provides an higher level interface.
-
-Fragment based streaming: 'sendFragment' are provided only at this level.
-
-'stateless' and 'transient' server processeses are also possible. the first are request-response
- . `transient` processes do not persist after timeout, so they restart anew after a timeout or a crash.
-
--}
-
-
-{-# LANGUAGE DeriveDataTypeable, UndecidableInstances
- ,ExistentialQuantification
- ,MultiParamTypeClasses
- ,FunctionalDependencies
- ,TypeSynonymInstances
- ,FlexibleInstances
- ,FlexibleContexts
- ,RecordWildCards
- ,OverloadedStrings
- ,ScopedTypeVariables
-
- #-}
-module MFlow (
-Flow, Params, HttpData(..),Processable(..)
-, Token(..), ProcList
--- * low level comunication primitives. Use `ask` instead
-,flushRec, flushResponse, receive, receiveReq, receiveReqTimeout, send, sendFlush, sendFragment
-, sendEndFragment, sendToMF
--- * Flow configuration
-,setNoScript,addMessageFlows,getMessageFlows,delMessageFlow, transient, stateless,anonymous
-,noScript,hlog, setNotFoundResponse,getNotFoundResponse,
--- * ByteString tags
--- | very basic but efficient bytestring tag formatting
-btag, bhtml, bbody,Attribs, addAttrs
--- * user
-, userRegister, setAdminUser, getAdminName, Auth(..),getAuthMethod, setAuthMethod
+{- | Non monadic low level primitives that implement the MFlow application server.
+See "MFlow.Form" for the higher level interface that you may use.
+
+it implements an scheduler of 'Processable' messages that are served according with
+the source identification and the verb invoked.
+The scheduler executed the appropriate workflow (using the workflow package).
+The workflow will send additional messages to the source and wait for the responses.
+The diaglog is identified by a 'Token', which is associated to the flow.
+. The computation state is optionally logged. On timeout, the process is killed. When invoked again,
+the execution state is recovered as if no interruption took place.
+
+There is no asumption about message codification, so instantiations
+of this scheduler for different infrastructures is possible,
+including non-Web based ones as long as they support or emulate cookies.
+
+"MFlow.Hack" is an instantiation for the Hack interface in a Web context.
+
+"MFlow.Wai" is a instantiation for the WAI interface.
+
+"MFlow.Forms" implements a monadic type safe interface with composabe widgets and and applicative
+combinator as well as an higher comunication interface.
+
+"MFlow.Forms.XHtml" is an instantiation for the Text.XHtml format
+
+"MFlow.Forms.Blaze.Html" is an instantaiation for blaze-html
+
+"MFlow.Forms.HSP" is an instantiation for the Haskell Server Pages format
+
+There are some @*.All@ packages that contain a mix of these instantiations.
+For exmaple, "MFlow.Wai.Blaze.Html.All" includes most of all necessary for using MFlow with
+Wai <http://hackage.haskell.org/package/wai> and
+Blaze-html <http://hackage.haskell.org/package/blaze-html>
+
+
+In order to manage resources, there are primitives that kill the process and its state after a timeout.
+
+All these details are hidden in the monad of "MFlow.Forms" that provides an higher level interface.
+
+Fragment based streaming: 'sendFragment' are provided only at this level.
+
+'stateless' and 'transient' server processeses are also possible. the first are request-response
+ . `transient` processes do not persist after timeout, so they restart anew after a timeout or a crash.
+
+-}
+
+
+{-# LANGUAGE DeriveDataTypeable, UndecidableInstances
+ ,ExistentialQuantification
+ ,MultiParamTypeClasses
+ ,FunctionalDependencies
+ ,TypeSynonymInstances
+ ,FlexibleInstances
+ ,FlexibleContexts
+ ,RecordWildCards
+ ,OverloadedStrings
+ ,ScopedTypeVariables
+ ,BangPatterns
+ #-}
+module MFlow (
+Flow, Params, HttpData(..),Processable(..)
+, Token(..), ProcList
+-- * low level comunication primitives. Use `ask` instead
+,flushRec, flushResponse, receive, receiveReq, receiveReqTimeout, send, sendFlush, sendFragment
+, sendEndFragment, sendToMF
+-- * Flow configuration
+,setNoScript,addMessageFlows,getMessageFlows,delMessageFlow, transient, stateless,anonymous
+,noScript,hlog, setNotFoundResponse,getNotFoundResponse,
+-- * ByteString tags
+-- | very basic but efficient bytestring tag formatting
+btag, bhtml, bbody,Attribs, addAttrs
+-- * user
+, userRegister, setAdminUser, getAdminName, Auth(..),getAuthMethod, setAuthMethod
-- * static files
-- * config
-,config, getConfig
-,setFilesPath
--- * internal use
-,addTokenToList,deleteTokenInList, msgScheduler,serveFile,newFlow
-,UserStr,PasswdStr, User(..),eUser
-
-)
-where
-import Control.Concurrent.MVar
-import Data.IORef
-import GHC.Conc(unsafeIOToSTM)
-import Data.Typeable
-import Data.Maybe(isJust, isNothing, fromMaybe, fromJust)
-import Data.Char(isSeparator)
-import Data.List(isPrefixOf,isSuffixOf,isInfixOf, elem , span, (\\),intersperse)
-import Control.Monad(when)
-
-import Data.Monoid
-import Control.Concurrent(forkIO,threadDelay,killThread, myThreadId, ThreadId)
-import Data.Char(toLower)
-
-import Unsafe.Coerce
-import System.IO.Unsafe
-import Data.TCache
-import Data.TCache.DefaultPersistence hiding(Indexable(..))
-import Data.TCache.Memoization
-import qualified Data.ByteString.Lazy.Char8 as B (head, readFile,ByteString, concat,pack, unpack,empty,append,cons,fromChunks)
-import Data.ByteString.Lazy.Internal (ByteString(Chunk))
-import qualified Data.ByteString.Char8 as SB
-import qualified Data.Map as M
-import System.IO
-import System.Time
-import Control.Workflow
-import MFlow.Cookies
-import Control.Monad.Trans
-import qualified Control.Exception as CE
-import Data.RefSerialize hiding (empty)
-import qualified Data.Text as T
-import System.Posix.Internals
-import Control.Exception
---import Debug.Trace
---(!>) = flip trace
-
-
--- | a Token identifies a flow that handle messages. The scheduler compose a Token with every `Processable`
--- message that arrives and send the mesage to the appropriate flow.
-data Token = Token{twfname,tuser, tind :: String , tpath :: [String], tenv:: Params, tblock:: MVar Bool, tsendq :: MVar Req, trecq :: MVar Resp} deriving Typeable
-
-instance Indexable Token where
- key (Token w u i _ _ _ _ _ )= i
--- if u== anonymous then u ++ i -- ++ "@" ++ w
--- else u -- ++ "@" ++ w
-
-instance Show Token where
- show t = "Token " ++ key t
-
-instance Read Token where
- readsPrec _ ('T':'o':'k':'e': 'n':' ':str1)
- | anonymous `isPrefixOf` str1= [(Token w anonymous i [] [] (newVar True) (newVar 0) (newVar 0), tail str2)]
- | otherwise = [(Token w ui "0" [] [] (newVar True) (newVar 0) (newVar 0), tail str2)]
-
- where
-
- (ui,str')= span(/='@') str1
- i = drop (length anonymous) ui
- (w,str2) = span (not . isSeparator) $ tail str'
- newVar _= unsafePerformIO $ newEmptyMVar
-
-
- readsPrec _ str= error $ "parse error in Token read from: "++ str
-
-instance Serializable Token where
- serialize = B.pack . show
- deserialize= read . B.unpack
- setPersist = \_ -> Just filePersist
-
-iorefqmap= unsafePerformIO . newMVar $ M.empty
-
-addTokenToList t@Token{..} =
- modifyMVar_ iorefqmap $ \ map ->
- return $ M.insert ( tind ++ twfname ++ tuser ) t map
-
-deleteTokenInList t@Token{..} =
- modifyMVar_ iorefqmap $ \ map ->
- return $ M.delete (tind ++ twfname ++ tuser) map
-
-getToken msg= do
- qmap <- readMVar iorefqmap
- let u= puser msg ; w= pwfname msg ; i=pind msg; ppath=pwfPath msg;penv= getParams msg
- let mqs = M.lookup ( i ++ w ++ u) qmap
- case mqs of
- Nothing -> do
- q <- newEmptyMVar -- `debug` (i++w++u)
+,config,getConfig
+,setFilesPath
+-- * internal use
+,addTokenToList,deleteTokenInList, msgScheduler,serveFile,newFlow
+,UserStr,PasswdStr, User(..),eUser
+
+)
+where
+import Control.Concurrent.MVar
+import Data.IORef
+import GHC.Conc(unsafeIOToSTM)
+import Data.Typeable
+import Data.Maybe(isJust, isNothing, fromMaybe, fromJust)
+import Data.Char(isSeparator)
+import Data.List(isPrefixOf,isSuffixOf,isInfixOf, elem , span, (\\),intersperse)
+import Control.Monad(when)
+
+import Data.Monoid
+import Control.Concurrent(forkIO,threadDelay,killThread, myThreadId, ThreadId)
+import Data.Char(toLower)
+
+import Unsafe.Coerce
+import System.IO.Unsafe
+import Data.TCache
+import Data.TCache.DefaultPersistence hiding(Indexable(..))
+import Data.TCache.Memoization
+import qualified Data.ByteString.Lazy.Char8 as B (head, readFile,ByteString, concat,pack, unpack,empty,append,cons,fromChunks)
+import Data.ByteString.Lazy.Internal (ByteString(Chunk))
+import qualified Data.ByteString.Char8 as SB
+import qualified Data.Map as M
+import System.IO
+import System.Time
+import Control.Workflow
+import MFlow.Cookies
+import Control.Monad.Trans
+import qualified Control.Exception as CE
+import Data.RefSerialize hiding (empty)
+import qualified Data.Text as T
+import System.Posix.Internals
+import Control.Exception
+import Crypto.PasswordStore
+
+
+--import Debug.Trace
+--(!>) = flip trace
+
+
+-- | a Token identifies a flow that handle messages. The scheduler compose a Token with every `Processable`
+-- message that arrives and send the mesage to the appropriate flow.
+data Token = Token{twfname,tuser, tind :: String , tpath :: [String], tenv:: Params, tblock:: MVar Bool, tsendq :: MVar Req, trecq :: MVar Resp} deriving Typeable
+
+instance Indexable Token where
+ key (Token w u i _ _ _ _ _ )= i
+-- if u== anonymous then u ++ i -- ++ "@" ++ w
+-- else u -- ++ "@" ++ w
+
+instance Show Token where
+ show t = "Token " ++ key t
+
+instance Read Token where
+ readsPrec _ ('T':'o':'k':'e': 'n':' ':str1)
+ | anonymous `isPrefixOf` str1= [(Token w anonymous i [] [] (newVar True) (newVar 0) (newVar 0), tail str2)]
+ | otherwise = [(Token w ui "0" [] [] (newVar True) (newVar 0) (newVar 0), tail str2)]
+
+ where
+
+ (ui,str')= span(/='@') str1
+ i = drop (length anonymous) ui
+ (w,str2) = span (not . isSeparator) $ tail str'
+ newVar _= unsafePerformIO $ newEmptyMVar
+
+
+ readsPrec _ str= error $ "parse error in Token read from: "++ str
+
+instance Serializable Token where
+ serialize = B.pack . show
+ deserialize= read . B.unpack
+ setPersist = \_ -> Just filePersist
+
+iorefqmap= unsafePerformIO . newMVar $ M.empty
+
+addTokenToList t@Token{..} =
+ modifyMVar_ iorefqmap $ \ map ->
+ return $ M.insert ( tind ++ twfname ++ tuser ) t map
+
+deleteTokenInList t@Token{..} =
+ modifyMVar_ iorefqmap $ \ map ->
+ return $ M.delete (tind ++ twfname ++ tuser) map
+
+getToken msg= do
+ qmap <- readMVar iorefqmap
+ let u= puser msg ; w= pwfname msg ; i=pind msg; ppath=pwfPath msg;penv= getParams msg
+ let mqs = M.lookup ( i ++ w ++ u) qmap
+ case mqs of
+ Nothing -> do
+ q <- newEmptyMVar -- `debug` (i++w++u)
qr <- newEmptyMVar
- pblock <- newMVar True
- let token= Token w u i ppath penv pblock q qr
- addTokenToList token
- return token
-
- Just token -> return token{tpath= ppath, tenv= penv}
-
-
-type Flow= (Token -> Workflow IO ())
-
-data HttpData = HttpData [(SB.ByteString,SB.ByteString)] [Cookie] ByteString | Error ByteString deriving (Typeable, Show)
-
-
-instance Monoid HttpData where
- mempty= HttpData [] [] B.empty
- mappend (HttpData h c s) (HttpData h' c' s')= HttpData (h++h') (c++ c') $ mappend s s'
-
--- | List of (wfname, workflow) pairs, to be scheduled depending on the message's pwfname
-type ProcList = WorkflowList IO Token ()
-
-
-data Req = forall a.( Processable a, Typeable a)=> Req a deriving Typeable
-
-type Params = [(String,String)]
-
-class Processable a where
- pwfname :: a -> String
- pwfname s= Prelude.head $ pwfPath s
- pwfPath :: a -> [String]
- puser :: a -> String
- pind :: a -> String
- getParams :: a -> Params
-
-instance Processable Token where
- pwfname = twfname
- pwfPath = tpath
- puser = tuser
- pind = tind
- getParams = tenv
-
-instance Processable Req where
- pwfname (Req x)= pwfname x
- pwfPath (Req x)= pwfPath x
- puser (Req x)= puser x
- pind (Req x)= pind x
- getParams (Req x)= getParams x
--- getServer (Req x)= getServer x
--- getPort (Req x)= getPort x
-
-data Resp = Fragm HttpData
- | EndFragm HttpData
- | Resp HttpData
-
-
-
-
--- | The anonymous user
-anonymous= "anon#"
-
--- | It is the path of the root flow
+ pblock <- newMVar True
+ let token= Token w u i ppath penv pblock q qr
+ addTokenToList token
+ return token
+
+ Just token -> return token{tpath= ppath, tenv= penv}
+
+
+type Flow= (Token -> Workflow IO ())
+
+data HttpData = HttpData [(SB.ByteString,SB.ByteString)] [Cookie] ByteString | Error ByteString deriving (Typeable, Show)
+
+
+instance Monoid HttpData where
+ mempty= HttpData [] [] B.empty
+ mappend (HttpData h c s) (HttpData h' c' s')= HttpData (h++h') (c++ c') $ mappend s s'
+
+-- | List of (wfname, workflow) pairs, to be scheduled depending on the message's pwfname
+type ProcList = WorkflowList IO Token ()
+
+
+data Req = forall a.( Processable a, Typeable a)=> Req a deriving Typeable
+
+type Params = [(String,String)]
+
+class Processable a where
+ pwfname :: a -> String
+ pwfname s= Prelude.head $ pwfPath s
+ pwfPath :: a -> [String]
+ puser :: a -> String
+ pind :: a -> String
+ getParams :: a -> Params
+
+instance Processable Token where
+ pwfname = twfname
+ pwfPath = tpath
+ puser = tuser
+ pind = tind
+ getParams = tenv
+
+instance Processable Req where
+ pwfname (Req x)= pwfname x
+ pwfPath (Req x)= pwfPath x
+ puser (Req x)= puser x
+ pind (Req x)= pind x
+ getParams (Req x)= getParams x
+-- getServer (Req x)= getServer x
+-- getPort (Req x)= getPort x
+
+data Resp = Fragm HttpData
+ | EndFragm HttpData
+ | Resp HttpData
+
+
+
+
+-- | The anonymous user
+anonymous= "anon#"
+
+-- | It is the path of the root flow
noScriptRef= unsafePerformIO $ newIORef "noscript"
-
-noScript= unsafePerformIO $ readIORef noScriptRef
+
+noScript= unsafePerformIO $ readIORef noScriptRef
-- | set the flow to be executed when the URL has no path. The home page.
--
-- By default it is "noscript".
-- Although it is changed by `runNavigation` to his own flow name.
-setNoScript scr= writeIORef noScriptRef scr
-
-{-
-instance (Monad m, Show a) => Traceable (Workflow m a) where
- debugf iox str = do
- x <- iox
- return $ debug x (str++" => Workflow "++ show x)
--}
--- | send a complete response
---send :: Token -> HttpData -> IO()
-send t@(Token _ _ _ _ _ _ _ qresp) msg= do
- ( putMVar qresp . Resp $ msg ) -- !> ("<<<<< send "++ show t)
-
-sendFlush t msg= flushRec t >> send t msg -- !> "sendFlush "
-
--- | send a response fragment. Useful for streaming. the last packet must be sent trough 'send'
-sendFragment :: Token -> HttpData -> IO()
-sendFragment (Token _ _ _ _ _ _ _ qresp) msg= putMVar qresp . Fragm $ msg
-
-{-# DEPRECATED sendEndFragment "use \"send\" to end a fragmented response instead" #-}
-sendEndFragment :: Token -> HttpData -> IO()
-sendEndFragment (Token _ _ _ _ _ _ _ qresp) msg= putMVar qresp $ EndFragm msg
-
---emptyReceive (Token queue _ _)= emptyQueue queue
-receive :: Typeable a => Token -> IO a
-receive t= receiveReq t >>= return . fromReq
-
-flushResponse t@(Token _ _ _ _ _ _ _ qresp)= tryTakeMVar qresp
-
-
-flushRec t@(Token _ _ _ _ _ _ queue _)= tryTakeMVar queue -- !> "flushRec"
-
-receiveReq :: Token -> IO Req
+setNoScript scr= writeIORef noScriptRef scr
+
+{-
+instance (Monad m, Show a) => Traceable (Workflow m a) where
+ debugf iox str = do
+ x <- iox
+ return $ debug x (str++" => Workflow "++ show x)
+-}
+-- | send a complete response
+--send :: Token -> HttpData -> IO()
+send t@(Token _ _ _ _ _ _ _ qresp) msg= do
+ ( putMVar qresp . Resp $ msg ) -- !> ("<<<<< send "++ show t)
+
+sendFlush t msg= flushRec t >> send t msg -- !> "sendFlush "
+
+-- | send a response fragment. Useful for streaming. the last packet must be sent trough 'send'
+sendFragment :: Token -> HttpData -> IO()
+sendFragment (Token _ _ _ _ _ _ _ qresp) msg= putMVar qresp . Fragm $ msg
+
+{-# DEPRECATED sendEndFragment "use \"send\" to end a fragmented response instead" #-}
+sendEndFragment :: Token -> HttpData -> IO()
+sendEndFragment (Token _ _ _ _ _ _ _ qresp) msg= putMVar qresp $ EndFragm msg
+
+--emptyReceive (Token queue _ _)= emptyQueue queue
+receive :: Typeable a => Token -> IO a
+receive t= receiveReq t >>= return . fromReq
+
+flushResponse t@(Token _ _ _ _ _ _ _ qresp)= tryTakeMVar qresp
+
+
+flushRec t@(Token _ _ _ _ _ _ queue _)= tryTakeMVar queue -- !> "flushRec"
+
+receiveReq :: Token -> IO Req
receiveReq t@(Token _ _ _ _ _ _ queue _)= do
r <- readMVar queue -- !> (">>>>>> receiveReq ")
- return r -- !> "receiveReq >>>>"
-
-fromReq :: Typeable a => Req -> a
-fromReq (Req x) = x' where
- x'= case cast x of
- Nothing -> error $ "receive: received type: "++ show (typeOf x) ++ " does not match the desired type:" ++ show (typeOf x')
- Just y -> y
-
-
-receiveReqTimeout :: Int
- -> Integer
- -> Token
- -> IO Req
-receiveReqTimeout 0 0 t= receiveReq t
-receiveReqTimeout time time2 t=
- let id= keyWF (twfname t) t in withKillTimeout id time time2 (receiveReq t)
-
-
-delMsgHistory t = do
- let statKey= keyWF (twfname t) t -- !> "wf" --let qnme= keyWF wfname t
- delWFHistory1 statKey -- `debug` "delWFHistory"
-
-
-
--- | executes a simple request-response computation that receive the params and return a response
---
--- It is used with `addMessageFlows`
---
--- There is a higuer level version @wstateless@ in "MFLow.Forms"
-stateless :: (Params -> IO HttpData) -> Flow
-stateless f = transient proc
- where
- proc t@(Token _ _ _ _ _ _ queue qresp) = loop t queue qresp
- loop t queue qresp=do
- req <- takeMVar queue -- !> (">>>>>> stateless " ++ thread t)
- resp <- f (getParams req)
- (putMVar qresp $ Resp resp ) -- !> ("<<<<<< stateless " ++thread t)
- loop t queue qresp -- !> ("enviado stateless " ++ thread t)
-
-
-
--- | Executes a monadic computation that send and receive messages, but does
--- not store its state in permanent storage. The process once stopped, will restart anew
---
----- It is used with `addMessageFlows` `hackMessageFlow` or `waiMessageFlow`
-transient :: (Token -> IO ()) -> Flow
-transient f= unsafeIOtoWF . f -- WF(\s -> f t>>= \x-> return (s, x) )
-
-
-_messageFlows :: MVar (WorkflowList IO Token ()) -- MVar (M.Map String (Token -> Workflow IO ()))
-_messageFlows= unsafePerformIO $ newMVar emptyFList
- where
- emptyFList= M.empty :: WorkflowList IO Token ()
-
--- | add a list of flows to be scheduled. Each entry in the list is a pair @(path, flow)@
-addMessageFlows wfs= modifyMVar_ _messageFlows(\ms -> return $ M.union (M.fromList $ map flt wfs)ms)
- where flt ("",f)= (noScript,f)
- flt e= e
-
--- | return the list of the scheduler
-getMessageFlows = readMVar _messageFlows
-
-delMessageFlow wfname= modifyMVar_ _messageFlows (\ms -> return $ M.delete wfname ms)
-
-
-sendToMF Token{..} msg= putMVar tsendq (Req msg) -- !> "sendToMF"
-
---recFromMF :: (Typeable a, Typeable c, Processable a) => Token -> a -> IO c
-recFromMF t@Token{..} = do
- m <- takeMVar trecq -- !> "recFromMF <<<<<< "
- case m of
- Resp r -> return r -- !> "<<<<<< recFromMF"
- Fragm r -> do
- result <- getStream r
- return result
-
- where
- getStream r = do
- mr <- takeMVar trecq
- case mr of
- Fragm h -> do
- rest <- unsafeInterleaveIO $ getStream h
- let result= mappend r rest
- return result
- EndFragm h -> do
- let result= mappend r h
- return result
-
- Resp h -> do
- let result= mappend r h
- return result
-
-
-
-
--- | The scheduler creates a Token with every `Processable`
--- message that arrives and send the mesage to the appropriate flow, then wait for the response
--- and return it.
---
--- It is the core of the application server. "MFLow.Wai" and "MFlow.Hack" use it
-msgScheduler
- :: (Typeable a,Processable a)
- => a -> IO (HttpData, ThreadId)
-msgScheduler x = do
+ return r -- !> "receiveReq >>>>"
+
+fromReq :: Typeable a => Req -> a
+fromReq (Req x) = x' where
+ x'= case cast x of
+ Nothing -> error $ "receive: received type: "++ show (typeOf x) ++ " does not match the desired type:" ++ show (typeOf x')
+ Just y -> y
+
+
+receiveReqTimeout :: Int
+ -> Integer
+ -> Token
+ -> IO Req
+receiveReqTimeout 0 0 t= receiveReq t
+receiveReqTimeout time time2 t=
+ let id= keyWF (twfname t) t in withKillTimeout id time time2 (receiveReq t)
+
+
+delMsgHistory t = do
+ let statKey= keyWF (twfname t) t -- !> "wf" --let qnme= keyWF wfname t
+ delWFHistory1 statKey -- `debug` "delWFHistory"
+
+
+
+-- | executes a simple request-response computation that receive the params and return a response
+--
+-- It is used with `addMessageFlows`
+--
+-- There is a higuer level version @wstateless@ in "MFLow.Forms"
+stateless :: (Params -> IO HttpData) -> Flow
+stateless f = transient proc
+ where
+ proc t@(Token _ _ _ _ _ _ queue qresp) = loop t queue qresp
+ loop t queue qresp=do
+ req <- takeMVar queue -- !> (">>>>>> stateless " ++ thread t)
+ resp <- f (getParams req)
+ (putMVar qresp $ Resp resp ) -- !> ("<<<<<< stateless " ++thread t)
+ loop t queue qresp -- !> ("enviado stateless " ++ thread t)
+
+
+
+-- | Executes a monadic computation that send and receive messages, but does
+-- not store its state in permanent storage. The process once stopped, will restart anew
+--
+---- It is used with `addMessageFlows` `hackMessageFlow` or `waiMessageFlow`
+transient :: (Token -> IO ()) -> Flow
+transient f= unsafeIOtoWF . f -- WF(\s -> f t>>= \x-> return (s, x) )
+
+
+_messageFlows :: MVar (WorkflowList IO Token ()) -- MVar (M.Map String (Token -> Workflow IO ()))
+_messageFlows= unsafePerformIO $ newMVar emptyFList
+ where
+ emptyFList= M.empty :: WorkflowList IO Token ()
+
+-- | add a list of flows to be scheduled. Each entry in the list is a pair @(path, flow)@
+addMessageFlows wfs= modifyMVar_ _messageFlows(\ms -> return $ M.union (M.fromList $ map flt wfs)ms)
+ where flt ("",f)= (noScript,f)
+ flt e= e
+
+-- | return the list of the scheduler
+getMessageFlows = readMVar _messageFlows
+
+delMessageFlow wfname= modifyMVar_ _messageFlows (\ms -> return $ M.delete wfname ms)
+
+
+sendToMF Token{..} msg= putMVar tsendq (Req msg) -- !> "sendToMF"
+
+--recFromMF :: (Typeable a, Typeable c, Processable a) => Token -> a -> IO c
+recFromMF t@Token{..} = do
+ m <- takeMVar trecq -- !> "recFromMF <<<<<< "
+ case m of
+ Resp r -> return r -- !> "<<<<<< recFromMF"
+ Fragm r -> do
+ result <- getStream r
+ return result
+
+ where
+ getStream r = do
+ mr <- takeMVar trecq
+ case mr of
+ Fragm h -> do
+ rest <- unsafeInterleaveIO $ getStream h
+ let result= mappend r rest
+ return result
+ EndFragm h -> do
+ let result= mappend r h
+ return result
+
+ Resp h -> do
+ let result= mappend r h
+ return result
+
+
+
+
+-- | The scheduler creates a Token with every `Processable`
+-- message that arrives and send the mesage to the appropriate flow, then wait for the response
+-- and return it.
+--
+-- It is the core of the application server. "MFLow.Wai" and "MFlow.Hack" use it
+msgScheduler
+ :: (Typeable a,Processable a)
+ => a -> IO (HttpData, ThreadId)
+msgScheduler x = do
token <- getToken x
- th <- myThreadId
+ th <- myThreadId
let wfname = takeWhile (/='/') $ pwfname x
- criticalSection (tblock token) $ do
- sendToMF token x -- !> show th
- th <- startMessageFlow wfname token
- r <- recFromMF token
- return (r,th) -- !> let HttpData _ _ r1=r in B.unpack r1
+ criticalSection (tblock token) $ do
+ sendToMF token x -- !> show th
+ th <- startMessageFlow wfname token
+ r <- recFromMF token
+ return (r,th) -- !> let HttpData _ _ r1=r in B.unpack r1
where
- criticalSection mv f= bracket
- (takeMVar mv)
- (putMVar mv)
+ criticalSection mv f= bracket
+ (takeMVar mv)
+ (putMVar mv)
$ const $ f
-
- --start the flow if not started yet
- startMessageFlow wfname token =
- forkIO $ do
- wfs <- getMessageFlows
- r <- startWF wfname token wfs -- !>( "init wf " ++ wfname)
- case r of
- Left NotFound -> do
- (sendFlush token =<< serveFile (pwfname x))
+
+ --start the flow if not started yet
+ startMessageFlow wfname token =
+ forkIO $ do
+ wfs <- getMessageFlows
+ r <- startWF wfname token wfs -- !>( "init wf " ++ wfname)
+ case r of
+ Left NotFound -> do
+ (sendFlush token =<< serveFile (pwfname x))
`CE.catch` \(e:: CE.SomeException) -> do
- showError wfname token (show e)
--- sendFlush token (Error NotFound $ "Not found: " <> pack wfname)
- deleteTokenInList token
-
- Left AlreadyRunning -> return () -- !> ("already Running " ++ wfname)
-
- Left Timeout -> do
- hFlush stdout -- !> ("TIMEOUT in msgScheduler" ++ (show $ unsafePerformIO myThreadId))
- deleteTokenInList token
-
- Left (WFException e)-> do
- showError wfname token e
- moveState wfname token token{tind= "error/"++tuser token}
- deleteTokenInList token -- !> "DELETETOKEN"
-
-
- Right _ -> delMsgHistory token >> return () -- !> ("finished " ++ wfname)
-
-
-
-showError wfname token@Token{..} e= do
- t <- return . calendarTimeToString =<< toCalendarTime =<< getClockTime
- let msg= errorMessage t e tuser (Prelude.concat $ intersperse "/" tpath) tenv
- logError msg
- fresp <- getNotFoundResponse
- let admin= getAdminName
- sendFlush token . Error $ fresp (tuser== admin) $ Prelude.concat[ "<br/>"++ s | s <- lines msg]
-
-
-errorMessage t e u path env=
- "\n---------------------ERROR-------------------------\
- \\nTIME=" ++ t ++"\n\n" ++
- e++
- "\n\nUSER= " ++ u ++
- "\n\nPATH= " ++ path ++
- "\n\nREQUEST:\n\n" ++
- show env
-
-line= unsafePerformIO $ newMVar ()
-
-logError err= do
- takeMVar line
- putStrLn err
- hSeek hlog SeekFromEnd 0
- hPutStrLn hlog err
- hFlush hlog
- putMVar line ()
-
-logFileName= "errlog"
-
-
-
--- | The handler of the error log
-hlog= unsafePerformIO $ openFile logFileName ReadWriteMode
-
------- USER MANAGEMENT -------
-
-data Auth = Auth{
- uregister :: UserStr -> PasswdStr -> (IO (Maybe String)),
- uvalidate :: UserStr -> PasswdStr -> (IO (Maybe String))}
-
-_authMethod= unsafePerformIO $ newIORef $ Auth tCacheRegister tCacheValidate
-
--- | set an authentication method
-setAuthMethod auth= writeIORef _authMethod auth
-
-getAuthMethod = readIORef _authMethod
-
-
-data User= User
- { userName :: String
- , upassword :: String
- } deriving (Read, Show, Typeable)
-
-
-eUser= User (error1 "username") (error1 "password")
-
-error1 s= error $ s ++ " undefined"
-
-userPrefix= "user/"
-instance Indexable User where
- key User{userName= user}= keyUserName user
-
--- | Return the key name of an user
-keyUserName n= userPrefix++n
-
-instance Serializable User where
- serialize= B.pack . show
- deserialize= read . B.unpack
- setPersist = \_ -> Just filePersist
-
--- | Register an user/password
-tCacheRegister :: String -> String -> IO (Maybe String)
-tCacheRegister user password = atomically $ do
- withSTMResources [newuser] doit
- where
- newuser= User user password
- doit [Just (User _ _)] = resources{toReturn= Just "user already exist"}
- doit [Nothing] = resources{toAdd= [newuser],toReturn= Nothing}
-
-tCacheValidate :: UserStr -> PasswdStr -> IO (Maybe String)
-tCacheValidate u p =
- let user= eUser{userName=u}
- in atomically
- $ withSTMResources [user]
- $ \ mu -> case mu of
- [Nothing] -> resources{toReturn= err }
- [Just (User _ pass )] -> resources{toReturn=
- case pass==p of
- True -> Nothing
- False -> err
- }
-
- where
- err= Just "Username or password invalid"
-
-userRegister u p= liftIO $ do
- Auth reg _ <- getAuthMethod :: IO Auth
- reg u p
-
-
-newtype Config= Config1 (M.Map String String) deriving (Read,Show,Typeable)
-
---defConfig= Config1 $ M.fromList
--- [("cadmin","admin")
--- ,("cjqueryScript","//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js")
--- ,("cjqueryCSS","//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css")
--- ,("cjqueryUI","//code.jquery.com/ui/1.10.3/jquery-ui.js")
--- ,("cnicEditUrl","//js.nicedit.com/nicEdit-latest.js")]
-
+ showError wfname token (show e)
+-- sendFlush token (Error NotFound $ "Not found: " <> pack wfname)
+ deleteTokenInList token
+
+ Left AlreadyRunning -> return () -- !> ("already Running " ++ wfname)
+
+ Left Timeout -> do
+ hFlush stdout -- !> ("TIMEOUT in msgScheduler" ++ (show $ unsafePerformIO myThreadId))
+ deleteTokenInList token
+
+ Left (WFException e)-> do
+ showError wfname token e
+ moveState wfname token token{tind= "error/"++tuser token}
+ deleteTokenInList token -- !> "DELETETOKEN"
+
+
+ Right _ -> delMsgHistory token >> return () -- !> ("finished " ++ wfname)
+
+
+
+showError wfname token@Token{..} e= do
+ t <- return . calendarTimeToString =<< toCalendarTime =<< getClockTime
+ let msg= errorMessage t e tuser (Prelude.concat $ intersperse "/" tpath) tenv
+ logError msg
+ fresp <- getNotFoundResponse
+ let admin= getAdminName
+ sendFlush token . Error $ fresp (tuser== admin) $ Prelude.concat[ "<br/>"++ s | s <- lines msg]
+
+
+errorMessage t e u path env=
+ "\n---------------------ERROR-------------------------\
+ \\nTIME=" ++ t ++"\n\n" ++
+ e++
+ "\n\nUSER= " ++ u ++
+ "\n\nPATH= " ++ path ++
+ "\n\nREQUEST:\n\n" ++
+ show env
+
+line= unsafePerformIO $ newMVar ()
+
+logError err= do
+ takeMVar line
+ putStrLn err
+ hSeek hlog SeekFromEnd 0
+ hPutStrLn hlog err
+ hFlush hlog
+ putMVar line ()
+
+logFileName= "errlog"
+
+
+
+-- | The handler of the error log
+hlog= unsafePerformIO $ openFile logFileName ReadWriteMode
+
+------ USER MANAGEMENT -------
+
+data Auth = Auth{
+ uregister :: UserStr -> PasswdStr -> (IO (Maybe String)),
+ uvalidate :: UserStr -> PasswdStr -> (IO (Maybe String))}
+
+_authMethod= unsafePerformIO $ newIORef $ Auth tCacheRegister tCacheValidate
+
+-- | set an authentication method. That includes the registration and validation calls.
+-- both return Nothing if sucessful. Otherwise they return a text mesage explaining the failure
+setAuthMethod auth= writeIORef _authMethod auth
+
+getAuthMethod = readIORef _authMethod
+
+
+data User= User
+ { userName :: String
+ , upassword :: String
+ } deriving (Read, Show, Typeable)
+
+
+eUser= User (error1 "username") (error1 "password")
+
+error1 s= error $ s ++ " undefined"
+
+userPrefix= "user/"
+instance Indexable User where
+ key User{userName= user}= keyUserName user
+
+-- | Return the key name of an user
+keyUserName n= userPrefix++n
+
+instance Serializable User where
+ serialize= B.pack . show
+ deserialize= read . B.unpack
+ setPersist = \_ -> Just filePersist
+
+-- | Register an user/password
+tCacheRegister :: String -> String -> IO (Maybe String)
+tCacheRegister user password= tCacheRegister' 14 user password
+
+tCacheRegister' strength user password= do
+ salted_password <- makePassword (SB.pack password) strength
+ atomically $ do
+ let newuser = User user (SB.unpack salted_password)
+ withSTMResources [newuser] $ doit newuser
+ where
+ doit newuser [Just (User _ _)] = resources{toReturn= Just "user already exist"}
+ doit newuser [Nothing] = resources{toAdd= [newuser],toReturn= Nothing}
+
+
+-- withSTMResources [newuser] doit
+-- where
+-- newuser= User user password
+-- doit [Just (User _ _)] = resources{toReturn= Just "user already exist"}
+-- doit [Nothing] = resources{toAdd= [newuser],toReturn= Nothing}
+
+tCacheValidate :: UserStr -> PasswdStr -> IO (Maybe String)
+tCacheValidate u p =
+ let user= eUser{userName=u}
+ in atomically
+ $ withSTMResources [user]
+ $ \ mu -> case mu of
+ [Nothing] -> resources{toReturn= err }
+ [Just u@(User _ pass )] -> resources{toReturn =
+ case verifyPassword (SB.pack p) (SB.pack pass)
+ || pass== p of -- for backward compatibility for unhashed passwords
+ True -> Nothing
+ False -> err
+ }
+ where
+ err= Just "Username or password invalid"
+
+-- | register an user with the auth Method
+userRegister :: MonadIO m => UserStr -> PasswdStr -> m (Maybe String)
+userRegister !u !p= liftIO $ do
+ Auth reg _ <- getAuthMethod :: IO Auth
+ reg u p
+
+
+newtype Config= Config1 (M.Map String String) deriving (Read,Show,Typeable)
+
+
data Config0 = Config{cadmin :: UserStr -- ^ Administrator name
,cjqueryScript :: String -- ^ URL of jquery
,cjqueryCSS :: String -- ^ URL of jqueryCSS
,cjqueryUI :: String -- ^ URL of jqueryUI
,cnicEditUrl :: String -- ^ URL of the nicEdit editor
}
- deriving (Read, Show, Typeable)
+ deriving (Read, Show, Typeable)
---defConfig0= Config "admin" "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js"
--- "//code.jquery.com/ui/1.10.3/themes/smoothness/jquery-ui.css"
--- "//code.jquery.com/ui/1.10.3/jquery-ui.js"
--- "//js.nicedit.com/nicEdit-latest.js"
---
---writeDefConfig0= writeFile "sal" $ show defConfig0
change :: Config0 -> Config
change Config{..} = Config1 $ M.fromList
@@ -558,370 +563,366 @@
readOld :: ByteString -> Config
readOld s= (change . read . B.unpack $ s)
-
-keyConfig= "mflow.config"
+
+keyConfig= "mflow.config"
instance Indexable Config where key _= keyConfig
-rconf :: DBRef Config
-rconf= getDBRef keyConfig
-
-instance Serializable Config where
- serialize = B.pack . show
+rconf :: DBRef Config
+rconf= getDBRef keyConfig
+
+instance Serializable Config where
+ serialize (Config1 c)= B.pack $ "Config1 (fromList[\n" <> (concat . intersperse ",\n" $ map show (M.toList c)) <> "])"
deserialize s = unsafePerformIO $ (return $! read $! B.unpack s)
- `CE.catch` \(e :: SomeException) -> return (readOld s)
- setPersist = \_ -> Just filePersist
+ `CE.catch` \(e :: SomeException) -> return (readOld s)
+ setPersist = \_ -> Just filePersist
-- | read a config variable from the config file \"mflow.config\". if it is not set, uses the second parameter and
-- add it to the configuration list, so next time the administrator can change it in the configuration file
-getConfig k v= case M.lookup k config of
+getConfig k v= case M.lookup k config of
Nothing -> unsafePerformIO $ setConfig k v >> return v
Just s -> s
-- | set an user-defined config variable
-setConfig k v= atomically $ do
- Config1 conf <- readConfig
- writeDBRef rconf $ Config1 $ M.insert k v conf
+setConfig k v= atomically $ do
+ Config1 conf <- readConfig
+ writeDBRef rconf $ Config1 $ M.insert k v conf
-- user ---
-
-type UserStr= String
-type PasswdStr= String
+
+type UserStr= String
+type PasswdStr= String
-- | set the Administrator user and password.
-- It must be defined in Main , before any configuration parameter is read, before the execution
--- of any flow
-setAdminUser :: MonadIO m => UserStr -> PasswdStr -> m ()
-setAdminUser user password= liftIO $ do
+-- of any flow
+setAdminUser :: MonadIO m => UserStr -> PasswdStr -> m ()
+setAdminUser user password= liftIO $ do
userRegister user password
setConfig "cadmin" user
--- atomically $ do
--- Config1 conf <- readConfig
--- writeDBRef rconf $ Config1 $ M.insert "cadmin" user conf
-
-
-
-getAdminName= getConfig "cadmin" "admin"
-
-
---------------- ERROR RESPONSES --------
-
-defNotFoundResponse isAdmin msg= fresp $
- case isAdmin of
- True -> B.pack msg
- _ -> "The administrator has been notified"
- where
- fresp msg=
- "<html><h4>Error 404: Page not found or error ocurred</h4> <p style=\"font-family:courier\">" <> msg <>"</p>" <>
- "<br/>" <> opts <> "<br/><a href=\"/\" >press here to go home</a></html>"
-
-
- paths= Prelude.map B.pack . M.keys $ unsafePerformIO getMessageFlows
- opts= "options: " <> B.concat (Prelude.map (\s ->
- "<a href=\"/"<> s <>"\">"<> s <>"</a>, ") $ filter (\s -> B.head s /= '_') paths)
-
-notFoundResponse= unsafePerformIO $ newIORef defNotFoundResponse
-
--- | set the 404 "not found" response.
---
--- The parameter is as follows:
--- (Bool Either if the user is Administrator or not
--- -> String The error string
--- -> HttpData) The response. See `defNotFoundResponse` code for an example
-
-setNotFoundResponse ::
- (Bool
- -> String
- -> ByteString)
- -> IO ()
-
-setNotFoundResponse f= liftIO $ writeIORef notFoundResponse f
-getNotFoundResponse= liftIO $ readIORef notFoundResponse
-
---------------- BASIC BYTESTRING TAGS -------------------
-
-
-type Attribs= [(String,String)]
--- | Writes a XML tag in a ByteString. It is the most basic form of formatting. For
--- more sophisticated formatting , use "MFlow.Forms.XHtml" or "MFlow.Forms.HSP".
-btag :: String -> Attribs -> ByteString -> ByteString
-btag t rs v= "<" <> pt <> attrs rs <> ">" <> v <> "</" <> pt <> ">"
- where
- pt= B.pack t
- attrs []= B.empty
- attrs rs= B.pack $ concatMap(\(n,v) -> (' ' : n) ++ "=\"" ++ v++ "\"" ) rs
-
--- |
--- > bhtml ats v= btag "html" ats v
-bhtml :: Attribs -> ByteString -> ByteString
-bhtml ats v= btag "html" ats v
-
-
--- |
--- > bbody ats v= btag "body" ats v
-bbody :: Attribs -> ByteString -> ByteString
-bbody ats v= btag "body" ats v
-
-addAttrs :: ByteString -> Attribs -> ByteString
-addAttrs (Chunk "<" (Chunk tag rest)) rs=
- Chunk "<"(Chunk tag (B.pack $ concatMap(\(n,v) -> (' ' : n) ++ "=" ++ v ) rs)) <> rest
-
-addAttrs other _ = error $ "addAttrs: byteString is not a tag: " ++ show other
-
-
-------------------- FILE SERVER -----------
-
--- | Set the path of the files in the web server. The links to the files are relative to it.
--- The files are cached (memoized) according with the "Data.TCache" policies in the program space. This avoid the blocking of
--- the efficient GHC threads by frequent IO calls.So it enhances the performance
--- in the context of heavy concurrence.
--- It uses 'Data.TCache.Memoization'.
--- The caching-uncaching follows the `setPersist` criteria
-setFilesPath :: MonadIO m => String -> m ()
-setFilesPath path= liftIO $ writeIORef rfilesPath path
-
-rfilesPath= unsafePerformIO $ newIORef "files/"
-
-serveFile path'= do
- when(let hpath= Prelude.head path' in hpath == '/' || hpath =='\\') $ error noperm
- when(not(".." `isSuffixOf` path') && ".." `isInfixOf` path') $ error noperm
- filesPath <- readIORef rfilesPath
- let path= filesPath ++ path'
- mr <- cachedByKey path 0 $ (B.readFile path >>= return . Just) `CE.catch` ioerr (return Nothing)
- case mr of
- Nothing -> error "not found" -- return $ HttpData [setMime "text/plain"] [] $ pack $ "not accessible"
- Just r ->
- let ext = reverse . takeWhile (/='.') $ reverse path
- mmime= lookup (map toLower ext) mimeTable
- mime = case mmime of Just m -> m ;Nothing -> "application/octet-stream"
-
- in return $ HttpData [setMime mime, ("Cache-Control", "max-age=360000")] [] r
- where
- noperm= "no permissions"
- ioerr x= \(e :: CE.IOException) -> x
- setMime x= ("Content-Type",x)
-
---------------------- FLOW ID GENERATOR ------------
-
-data NFlow= NFlow !Integer deriving (Read, Show, Typeable)
-
-
-
-instance Indexable NFlow where
- key _= "Flow"
-
-instance Serializable NFlow where
- serialize= B.pack . show
- deserialize= read . B.unpack
- setPersist = \_ -> Just filePersist
-
-rflow= getDBRef . key $ NFlow undefined
-
-newFlow= do
- TOD t _ <- getClockTime
- atomically $ do
- NFlow n <- readDBRef rflow `onNothing` return (NFlow 0)
- writeDBRef rflow . NFlow $ n+1
- return . SB.pack . show $ t + n
-
-
-mimeTable=[
- ("html", "text/html"),
- ("htm", "text/html"),
- ("txt", "text/plain"),
- ("hs", "text/plain"),
- ("lhs", "text/plain"),
- ("jpeg", "image/jpeg"),
- ("pdf", "application/pdf"),
- ("js", "application/x-javascript"),
- ("gif", "image/gif"),
- ("bmp", "image/bmp"),
- ("ico", "image/x-icon"),
- ("doc", "application/msword"),
- ("jpg", "image/jpeg"),
- ("eps", "application/postscript"),
- ("zip", "application/zip"),
- ("exe", "application/octet-stream"),
- ("tif", "image/tiff"),
- ("tiff", "image/tiff"),
- ("mov", "video/quicktime"),
- ("movie", "video/x-sgi-movie"),
- ("mp2", "video/mpeg"),
- ("mp3", "audio/mpeg"),
- ("mpa", "video/mpeg"),
- ("mpe", "video/mpeg"),
- ("mpeg", "video/mpeg"),
- ("mpg", "video/mpeg"),
- ("mpp", "application/vnd.ms-project"),
- ("323", "text/h323"),
- ("*", "application/octet-stream"),
- ("acx", "application/internet-property-stream"),
- ("ai", "application/postscript"),
- ("aif", "audio/x-aiff"),
- ("aifc", "audio/x-aiff"),
- ("aiff", "audio/x-aiff"),
- ("asf", "video/x-ms-asf"),
- ("asr", "video/x-ms-asf"),
- ("asx", "video/x-ms-asf"),
- ("au", "audio/basic"),
- ("avi", "video/x-msvideo"),
- ("axs", "application/olescript"),
- ("bas", "text/plain"),
- ("bcpio", "application/x-bcpio"),
- ("bin", "application/octet-stream"),
- ("c", "text/plain"),
- ("cat", "application/vnd.ms-pkiseccat"),
- ("cdf", "application/x-cdf"),
- ("cdf", "application/x-netcdf"),
- ("cer", "application/x-x509-ca-cert"),
- ("class", "application/octet-stream"),
- ("clp", "application/x-msclip"),
- ("cmx", "image/x-cmx"),
- ("cod", "image/cis-cod"),
- ("cpio", "application/x-cpio"),
- ("crd", "application/x-mscardfile"),
- ("crl", "application/pkix-crl"),
- ("crt", "application/x-x509-ca-cert"),
- ("csh", "application/x-csh"),
- ("css", "text/css"),
- ("dcr", "application/x-director"),
- ("der", "application/x-x509-ca-cert"),
- ("dir", "application/x-director"),
- ("dll", "application/x-msdownload"),
- ("dms", "application/octet-stream"),
- ("dot", "application/msword"),
- ("dvi", "application/x-dvi"),
- ("dxr", "application/x-director"),
- ("eps", "application/postscript"),
- ("etx", "text/x-setext"),
- ("evy", "application/envoy"),
- ("fif", "application/fractals"),
- ("flr", "x-world/x-vrml"),
- ("gtar", "application/x-gtar"),
- ("gz", "application/x-gzip"),
- ("h", "text/plain"),
- ("hdf", "application/x-hdf"),
- ("hlp", "application/winhlp"),
- ("hqx", "application/mac-binhex40"),
- ("hta", "application/hta"),
- ("htc", "text/x-component"),
- ("htt", "text/webviewhtml"),
- ("ief", "image/ief"),
- ("iii", "application/x-iphone"),
- ("ins", "application/x-internet-signup"),
- ("isp", "application/x-internet-signup"),
- ("jfif", "image/pipeg"),
- ("jpe", "image/jpeg"),
- ("latex", "application/x-latex"),
- ("lha", "application/octet-stream"),
- ("lsf", "video/x-la-asf"),
- ("lsx", "video/x-la-asf"),
- ("lzh", "application/octet-stream"),
- ("m13", "application/x-msmediaview"),
- ("m14", "application/x-msmediaview"),
- ("m3u", "audio/x-mpegurl"),
- ("man", "application/x-troff-man"),
- ("mdb", "application/x-msaccess"),
- ("me", "application/x-troff-me"),
- ("mht", "message/rfc822"),
- ("mhtml", "message/rfc822"),
- ("mid", "audio/mid"),
- ("mny", "application/x-msmoney"),
- ("mpv2", "video/mpeg"),
- ("ms", "application/x-troff-ms"),
- ("msg", "application/vnd.ms-outlook"),
- ("mvb", "application/x-msmediaview"),
- ("nc", "application/x-netcdf"),
- ("nws", "message/rfc822"),
- ("oda", "application/oda"),
- ("p10", "application/pkcs10"),
- ("p12", "application/x-pkcs12"),
- ("p7b", "application/x-pkcs7-certificates"),
- ("p7c", "application/x-pkcs7-mime"),
- ("p7m", "application/x-pkcs7-mime"),
- ("p7r", "application/x-pkcs7-certreqresp"),
- ("p7s", "application/x-pkcs7-signature"),
- ("png", "image/png"),
- ("pbm", "image/x-portable-bitmap"),
- ("pfx", "application/x-pkcs12"),
- ("pgm", "image/x-portable-graymap"),
- ("pko", "application/ynd.ms-pkipko"),
- ("pma", "application/x-perfmon"),
- ("pmc", "application/x-perfmon"),
- ("pml", "application/x-perfmon"),
- ("pmr", "application/x-perfmon"),
- ("pmw", "application/x-perfmon"),
- ("pnm", "image/x-portable-anymap"),
- ("pot", "application/vnd.ms-powerpoint"),
- ("ppm", "image/x-portable-pixmap"),
- ("pps", "application/vnd.ms-powerpoint"),
- ("ppt", "application/vnd.ms-powerpoint"),
- ("prf", "application/pics-rules"),
- ("ps", "application/postscript"),
- ("pub", "application/x-mspublisher"),
- ("qt", "video/quicktime"),
- ("ra", "audio/x-pn-realaudio"),
- ("ram", "audio/x-pn-realaudio"),
- ("ras", "image/x-cmu-raster"),
- ("rgb", "image/x-rgb"),
- ("rmi", "audio/mid"),
- ("roff", "application/x-troff"),
- ("rtf", "application/rtf"),
- ("rtx", "text/richtext"),
- ("scd", "application/x-msschedule"),
- ("sct", "text/scriptlet"),
- ("setpay", "application/set-payment-initiation"),
- ("setreg", "application/set-registration-initiation"),
- ("sh", "application/x-sh"),
- ("shar", "application/x-shar"),
- ("sit", "application/x-stuffit"),
- ("snd", "audio/basic"),
- ("spc", "application/x-pkcs7-certificates"),
- ("spl", "application/futuresplash"),
- ("src", "application/x-wais-source"),
- ("sst", "application/vnd.ms-pkicertstore"),
- ("stl", "application/vnd.ms-pkistl"),
- ("stm", "text/html"),
- ("sv4cpio", "application/x-sv4cpio"),
- ("sv4crc", "application/x-sv4crc"),
- ("svg", "image/svg+xml"),
- ("swf", "application/x-shockwave-flash"),
- ("t", "application/x-troff"),
- ("tar", "application/x-tar"),
- ("tcl", "application/x-tcl"),
- ("tex", "application/x-tex"),
- ("texi", "application/x-texinfo"),
- ("texinfo", "application/x-texinfo"),
- ("tgz", "application/x-compressed"),
- ("tr", "application/x-troff"),
- ("trm", "application/x-msterminal"),
- ("tsv", "text/tab-separated-values"),
- ("uls", "text/iuls"),
- ("ustar", "application/x-ustar"),
- ("vcf", "text/x-vcard"),
- ("vrml", "x-world/x-vrml"),
- ("wav", "audio/x-wav"),
- ("wcm", "application/vnd.ms-works"),
- ("wdb", "application/vnd.ms-works"),
- ("wks", "application/vnd.ms-works"),
- ("wmf", "application/x-msmetafile"),
- ("wps", "application/vnd.ms-works"),
- ("wri", "application/x-mswrite"),
- ("wrl", "x-world/x-vrml"),
- ("wrz", "x-world/x-vrml"),
- ("xaf", "x-world/x-vrml"),
- ("xbm", "image/x-xbitmap"),
- ("xla", "application/vnd.ms-excel"),
- ("xlc", "application/vnd.ms-excel"),
- ("xlm", "application/vnd.ms-excel"),
- ("xls", "application/vnd.ms-excel"),
- ("xlt", "application/vnd.ms-excel"),
- ("xlw", "application/vnd.ms-excel"),
- ("xof", "x-world/x-vrml"),
- ("xpm", "image/x-xpixmap"),
- ("xwd", "image/x-xwindowdump"),
- ("z", "application/x-compress")
-
- ]
-
+
+
+getAdminName= getConfig "cadmin" "admin"
+
+
+--------------- ERROR RESPONSES --------
+
+defNotFoundResponse isAdmin msg= fresp $
+ case isAdmin of
+ True -> B.pack msg
+ _ -> "The administrator has been notified"
+ where
+ fresp msg=
+ "<html><h4>Error 404: Page not found or error ocurred</h4> <p style=\"font-family:courier\">" <> msg <>"</p>" <>
+ "<br/>" <> opts <> "<br/><a href=\"/\" >press here to go home</a></html>"
+
+
+ paths= Prelude.map B.pack . M.keys $ unsafePerformIO getMessageFlows
+ opts= "options: " <> B.concat (Prelude.map (\s ->
+ "<a href=\"/"<> s <>"\">"<> s <>"</a>, ") $ filter (\s -> B.head s /= '_') paths)
+
+notFoundResponse= unsafePerformIO $ newIORef defNotFoundResponse
+
+-- | set the 404 "not found" response.
+--
+-- The parameter is as follows:
+-- (Bool Either if the user is Administrator or not
+-- -> String The error string
+-- -> HttpData) The response. See `defNotFoundResponse` code for an example
+
+setNotFoundResponse ::
+ (Bool
+ -> String
+ -> ByteString)
+ -> IO ()
+
+setNotFoundResponse f= liftIO $ writeIORef notFoundResponse f
+getNotFoundResponse= liftIO $ readIORef notFoundResponse
+
+--------------- BASIC BYTESTRING TAGS -------------------
+
+
+type Attribs= [(String,String)]
+-- | Writes a XML tag in a ByteString. It is the most basic form of formatting. For
+-- more sophisticated formatting , use "MFlow.Forms.XHtml" or "MFlow.Forms.HSP".
+btag :: String -> Attribs -> ByteString -> ByteString
+btag t rs v= "<" <> pt <> attrs rs <> ">" <> v <> "</" <> pt <> ">"
+ where
+ pt= B.pack t
+ attrs []= B.empty
+ attrs rs= B.pack $ concatMap(\(n,v) -> (' ' : n) ++ "=\"" ++ v++ "\"" ) rs
+
+-- |
+-- > bhtml ats v= btag "html" ats v
+bhtml :: Attribs -> ByteString -> ByteString
+bhtml ats v= btag "html" ats v
+
+
+-- |
+-- > bbody ats v= btag "body" ats v
+bbody :: Attribs -> ByteString -> ByteString
+bbody ats v= btag "body" ats v
+
+addAttrs :: ByteString -> Attribs -> ByteString
+addAttrs (Chunk "<" (Chunk tag rest)) rs=
+ Chunk "<"(Chunk tag (B.pack $ concatMap(\(n,v) -> (' ' : n) ++ "=" ++ v ) rs)) <> rest
+
+addAttrs other _ = error $ "addAttrs: byteString is not a tag: " ++ show other
+
+
+------------------- FILE SERVER -----------
+
+-- | Set the path of the files in the web server. The links to the files are relative to it.
+-- The files are cached (memoized) according with the "Data.TCache" policies in the program space. This avoid the blocking of
+-- the efficient GHC threads by frequent IO calls.So it enhances the performance
+-- in the context of heavy concurrence.
+-- It uses 'Data.TCache.Memoization'.
+-- The caching-uncaching follows the `setPersist` criteria
+setFilesPath :: MonadIO m => String -> m ()
+setFilesPath !path= liftIO $ writeIORef rfilesPath path
+
+rfilesPath= unsafePerformIO $ newIORef "files/"
+
+serveFile path'= do
+ when(let hpath= Prelude.head path' in hpath == '/' || hpath =='\\') $ error noperm
+ when(not(".." `isSuffixOf` path') && ".." `isInfixOf` path') $ error noperm
+ filesPath <- readIORef rfilesPath
+ let path= filesPath ++ path'
+ mr <- cachedByKey path 0 $ (B.readFile path >>= return . Just) `CE.catch` ioerr (return Nothing)
+ case mr of
+ Nothing -> error "not found" -- return $ HttpData [setMime "text/plain"] [] $ pack $ "not accessible"
+ Just r ->
+ let ext = reverse . takeWhile (/='.') $ reverse path
+ mmime= lookup (map toLower ext) mimeTable
+ mime = case mmime of Just m -> m ;Nothing -> "application/octet-stream"
+
+ in return $ HttpData [setMime mime, ("Cache-Control", "max-age=360000")] [] r
+ where
+ noperm= "no permissions"
+ ioerr x= \(e :: CE.IOException) -> x
+ setMime x= ("Content-Type",x)
+
+--------------------- FLOW ID GENERATOR ------------
+
+data NFlow= NFlow !Integer deriving (Read, Show, Typeable)
+
+
+
+instance Indexable NFlow where
+ key _= "Flow"
+
+instance Serializable NFlow where
+ serialize= B.pack . show
+ deserialize= read . B.unpack
+ setPersist = \_ -> Just filePersist
+
+rflow= getDBRef . key $ NFlow undefined
+
+newFlow= do
+ TOD t _ <- getClockTime
+ atomically $ do
+ NFlow n <- readDBRef rflow `onNothing` return (NFlow 0)
+ writeDBRef rflow . NFlow $ n+1
+ return . SB.pack . show $ t + n
+
+
+mimeTable=[
+ ("html", "text/html"),
+ ("htm", "text/html"),
+ ("txt", "text/plain"),
+ ("hs", "text/plain"),
+ ("lhs", "text/plain"),
+ ("jpeg", "image/jpeg"),
+ ("pdf", "application/pdf"),
+ ("js", "application/x-javascript"),
+ ("gif", "image/gif"),
+ ("bmp", "image/bmp"),
+ ("ico", "image/x-icon"),
+ ("doc", "application/msword"),
+ ("jpg", "image/jpeg"),
+ ("eps", "application/postscript"),
+ ("zip", "application/zip"),
+ ("exe", "application/octet-stream"),
+ ("tif", "image/tiff"),
+ ("tiff", "image/tiff"),
+ ("mov", "video/quicktime"),
+ ("movie", "video/x-sgi-movie"),
+ ("mp2", "video/mpeg"),
+ ("mp3", "audio/mpeg"),
+ ("mpa", "video/mpeg"),
+ ("mpe", "video/mpeg"),
+ ("mpeg", "video/mpeg"),
+ ("mpg", "video/mpeg"),
+ ("mpp", "application/vnd.ms-project"),
+ ("323", "text/h323"),
+ ("*", "application/octet-stream"),
+ ("acx", "application/internet-property-stream"),
+ ("ai", "application/postscript"),
+ ("aif", "audio/x-aiff"),
+ ("aifc", "audio/x-aiff"),
+ ("aiff", "audio/x-aiff"),
+ ("asf", "video/x-ms-asf"),
+ ("asr", "video/x-ms-asf"),
+ ("asx", "video/x-ms-asf"),
+ ("au", "audio/basic"),
+ ("avi", "video/x-msvideo"),
+ ("axs", "application/olescript"),
+ ("bas", "text/plain"),
+ ("bcpio", "application/x-bcpio"),
+ ("bin", "application/octet-stream"),
+ ("c", "text/plain"),
+ ("cat", "application/vnd.ms-pkiseccat"),
+ ("cdf", "application/x-cdf"),
+ ("cdf", "application/x-netcdf"),
+ ("cer", "application/x-x509-ca-cert"),
+ ("class", "application/octet-stream"),
+ ("clp", "application/x-msclip"),
+ ("cmx", "image/x-cmx"),
+ ("cod", "image/cis-cod"),
+ ("cpio", "application/x-cpio"),
+ ("crd", "application/x-mscardfile"),
+ ("crl", "application/pkix-crl"),
+ ("crt", "application/x-x509-ca-cert"),
+ ("csh", "application/x-csh"),
+ ("css", "text/css"),
+ ("dcr", "application/x-director"),
+ ("der", "application/x-x509-ca-cert"),
+ ("dir", "application/x-director"),
+ ("dll", "application/x-msdownload"),
+ ("dms", "application/octet-stream"),
+ ("dot", "application/msword"),
+ ("dvi", "application/x-dvi"),
+ ("dxr", "application/x-director"),
+ ("eps", "application/postscript"),
+ ("etx", "text/x-setext"),
+ ("evy", "application/envoy"),
+ ("fif", "application/fractals"),
+ ("flr", "x-world/x-vrml"),
+ ("gtar", "application/x-gtar"),
+ ("gz", "application/x-gzip"),
+ ("h", "text/plain"),
+ ("hdf", "application/x-hdf"),
+ ("hlp", "application/winhlp"),
+ ("hqx", "application/mac-binhex40"),
+ ("hta", "application/hta"),
+ ("htc", "text/x-component"),
+ ("htt", "text/webviewhtml"),
+ ("ief", "image/ief"),
+ ("iii", "application/x-iphone"),
+ ("ins", "application/x-internet-signup"),
+ ("isp", "application/x-internet-signup"),
+ ("jfif", "image/pipeg"),
+ ("jpe", "image/jpeg"),
+ ("latex", "application/x-latex"),
+ ("lha", "application/octet-stream"),
+ ("lsf", "video/x-la-asf"),
+ ("lsx", "video/x-la-asf"),
+ ("lzh", "application/octet-stream"),
+ ("m13", "application/x-msmediaview"),
+ ("m14", "application/x-msmediaview"),
+ ("m3u", "audio/x-mpegurl"),
+ ("man", "application/x-troff-man"),
+ ("mdb", "application/x-msaccess"),
+ ("me", "application/x-troff-me"),
+ ("mht", "message/rfc822"),
+ ("mhtml", "message/rfc822"),
+ ("mid", "audio/mid"),
+ ("mny", "application/x-msmoney"),
+ ("mpv2", "video/mpeg"),
+ ("ms", "application/x-troff-ms"),
+ ("msg", "application/vnd.ms-outlook"),
+ ("mvb", "application/x-msmediaview"),
+ ("nc", "application/x-netcdf"),
+ ("nws", "message/rfc822"),
+ ("oda", "application/oda"),
+ ("p10", "application/pkcs10"),
+ ("p12", "application/x-pkcs12"),
+ ("p7b", "application/x-pkcs7-certificates"),
+ ("p7c", "application/x-pkcs7-mime"),
+ ("p7m", "application/x-pkcs7-mime"),
+ ("p7r", "application/x-pkcs7-certreqresp"),
+ ("p7s", "application/x-pkcs7-signature"),
+ ("png", "image/png"),
+ ("pbm", "image/x-portable-bitmap"),
+ ("pfx", "application/x-pkcs12"),
+ ("pgm", "image/x-portable-graymap"),
+ ("pko", "application/ynd.ms-pkipko"),
+ ("pma", "application/x-perfmon"),
+ ("pmc", "application/x-perfmon"),
+ ("pml", "application/x-perfmon"),
+ ("pmr", "application/x-perfmon"),
+ ("pmw", "application/x-perfmon"),
+ ("pnm", "image/x-portable-anymap"),
+ ("pot", "application/vnd.ms-powerpoint"),
+ ("ppm", "image/x-portable-pixmap"),
+ ("pps", "application/vnd.ms-powerpoint"),
+ ("ppt", "application/vnd.ms-powerpoint"),
+ ("prf", "application/pics-rules"),
+ ("ps", "application/postscript"),
+ ("pub", "application/x-mspublisher"),
+ ("qt", "video/quicktime"),
+ ("ra", "audio/x-pn-realaudio"),
+ ("ram", "audio/x-pn-realaudio"),
+ ("ras", "image/x-cmu-raster"),
+ ("rgb", "image/x-rgb"),
+ ("rmi", "audio/mid"),
+ ("roff", "application/x-troff"),
+ ("rtf", "application/rtf"),
+ ("rtx", "text/richtext"),
+ ("scd", "application/x-msschedule"),
+ ("sct", "text/scriptlet"),
+ ("setpay", "application/set-payment-initiation"),
+ ("setreg", "application/set-registration-initiation"),
+ ("sh", "application/x-sh"),
+ ("shar", "application/x-shar"),
+ ("sit", "application/x-stuffit"),
+ ("snd", "audio/basic"),
+ ("spc", "application/x-pkcs7-certificates"),
+ ("spl", "application/futuresplash"),
+ ("src", "application/x-wais-source"),
+ ("sst", "application/vnd.ms-pkicertstore"),
+ ("stl", "application/vnd.ms-pkistl"),
+ ("stm", "text/html"),
+ ("sv4cpio", "application/x-sv4cpio"),
+ ("sv4crc", "application/x-sv4crc"),
+ ("svg", "image/svg+xml"),
+ ("swf", "application/x-shockwave-flash"),
+ ("t", "application/x-troff"),
+ ("tar", "application/x-tar"),
+ ("tcl", "application/x-tcl"),
+ ("tex", "application/x-tex"),
+ ("texi", "application/x-texinfo"),
+ ("texinfo", "application/x-texinfo"),
+ ("tgz", "application/x-compressed"),
+ ("tr", "application/x-troff"),
+ ("trm", "application/x-msterminal"),
+ ("tsv", "text/tab-separated-values"),
+ ("uls", "text/iuls"),
+ ("ustar", "application/x-ustar"),
+ ("vcf", "text/x-vcard"),
+ ("vrml", "x-world/x-vrml"),
+ ("wav", "audio/x-wav"),
+ ("wcm", "application/vnd.ms-works"),
+ ("wdb", "application/vnd.ms-works"),
+ ("wks", "application/vnd.ms-works"),
+ ("wmf", "application/x-msmetafile"),
+ ("wps", "application/vnd.ms-works"),
+ ("wri", "application/x-mswrite"),
+ ("wrl", "x-world/x-vrml"),
+ ("wrz", "x-world/x-vrml"),
+ ("xaf", "x-world/x-vrml"),
+ ("xbm", "image/x-xbitmap"),
+ ("xla", "application/vnd.ms-excel"),
+ ("xlc", "application/vnd.ms-excel"),
+ ("xlm", "application/vnd.ms-excel"),
+ ("xls", "application/vnd.ms-excel"),
+ ("xlt", "application/vnd.ms-excel"),
+ ("xlw", "application/vnd.ms-excel"),
+ ("xof", "x-world/x-vrml"),
+ ("xpm", "image/x-xpixmap"),
+ ("xwd", "image/x-xwindowdump"),
+ ("z", "application/x-compress")
+
+ ]
+
Reference in New Issue View Git Blame Copy Permalink