diff --git a/patching/patches/MFlow-0.3.3.patch b/patching/patches/MFlow-0.3.3.patch deleted file mode 100644 index 90b63f39..00000000 --- a/patching/patches/MFlow-0.3.3.patch +++ /dev/null @@ -1,20 +0,0 @@ -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-03-11 21:46:17.260400422 +0200 -+++ new/src/MFlow/Wai/Blaze/Html/All.hs 2014-03-11 21:46:16.000000000 +0200 -@@ -36,7 +36,7 @@ - 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 -+import qualified Network.Wai.Handler.Warp as Warp - import Data.TCache - import Text.Blaze.Internal(text) - -@@ -74,6 +74,6 @@ - when(not $ null n) $ setNoScript n - addMessageFlows[(n, runFlow f)] - porti <- getPort -- wait $ run porti waiMessageFlow -+ wait $ Warp.run porti waiMessageFlow - --runSettings defaultSettings{settingsTimeout = 20, settingsPort= porti} waiMessageFlow - diff --git a/patching/patches/MFlow-0.4.4.patch b/patching/patches/MFlow-0.4.4.patch deleted file mode 100644 index 3c305c99..00000000 --- a/patching/patches/MFlow-0.4.4.patch +++ /dev/null @@ -1,12 +0,0 @@ -diff -ru orig/MFlow.cabal new/MFlow.cabal ---- orig/MFlow.cabal 2014-04-03 19:38:07.181525338 +0300 -+++ new/MFlow.cabal 2014-04-03 19:38:07.000000000 +0300 -@@ -104,7 +104,7 @@ - utf8-string -any, wai >=2.0.0, case-insensitive -any, - http-types -any, conduit -any, text -any, parsec -any, warp -any, - warp-tls -any, random -any, blaze-html -any, blaze-markup -any, -- monadloc -any, clientsession ==0.9.0.3 -+ monadloc -any, clientsession ==0.9.0.3, conduit-extra - exposed-modules: MFlow MFlow.Wai.Blaze.Html.All MFlow.Forms - MFlow.Forms.Admin MFlow.Cookies MFlow.Wai - MFlow.Forms.Blaze.Html MFlow.Forms.Test diff --git a/patching/patches/MFlow-0.4.5.4.patch b/patching/patches/MFlow-0.4.5.4.patch new file mode 100644 index 00000000..56eef4bb --- /dev/null +++ b/patching/patches/MFlow-0.4.5.4.patch @@ -0,0 +1,13157 @@ +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 ) +--- +--- 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 ) ++-- ++-- 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 () +--- +--- @ +--- setHeader $ \c -> +--- \ +--- \ +--- \ my title \ +--- \) +--- \ +--- \ +--- \<% c %\> +--- \ +--- \ +--- @ +--- +--- 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` ) `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 () ++-- ++-- @ ++-- setHeader $ \c -> ++-- \ ++-- \ ++-- \ my title \ ++-- \) ++-- \ ++-- \ ++-- \<% c %\> ++-- \ ++-- \ ++-- @ ++-- ++-- 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` ) `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¶m2=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")) "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")) = 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 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 ++ 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) 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) 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)) 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 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)) 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 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 +- 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 ++ 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 = $('
' + xhr + '
');\ +- \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 = $('
' + xhr + '
');\ ++ \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') 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') 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 = $('
' + xhr + '
');\ +- \id1.html(msg);\ +- \}\ +- \};\ +- \$.ajax(dialogOpts);\ +- \return false;\ +- \});\ +- \}\n" ++ \autoEvalForm(id);\ ++ \},\ ++ \error: function (xhr, status, error) {\ ++ \var msg = $('
' + xhr + '
');\ ++ \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 = $('
' + xhr + '
');\ +- \id1.html(msg);\ ++ \error: function (xhr, status, error) {\ ++ \var msg = $('
' + xhr + '
');\ ++ \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 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) 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" <|> li <<< (wlink OptionA2 << "Option A2" <|>... +--- > 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 or
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 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) 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" <|> li <<< (wlink OptionA2 << "Option A2" <|>... ++-- > 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 or 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) "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) " ") ++> 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 = $('
' + xhr + '
');\ +- \id1.html(msg);\ +- \}\ +- \};\ +- \$.ajax(dialogOpts);\ +- \return false;\ +- \});\ +- \}\n" ++ \ajaxPostForm(id);\ ++ \},\ ++ \error: function (xhr, status, error) {\ ++ \var msg = $('
' + xhr + '
');\ ++ \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 = $('
' + xhr + '
');\ +- \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) 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 ' + xhr + '');\ ++ \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) 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 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 = $('
' + xhr + '
');\ ++ \error: function (xhr, status, error) {\ ++ \var msg = $('
' + xhr + '
');\ + \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 +- +-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 () 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 () 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 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 ) +- +- +-[@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 '= 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 ++ ++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 () 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 () 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 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 ) ++ ++ ++[@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 '),(|*>),(|+|), (**>),(<**),(<|>),(<*),(<$>),(<*>),(>:>) +- +----- * 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 +-,(<<<),(++>),(<++),(.) +- +--- * 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 ++,(<<<),(++>),(<++),(.) ++ ++-- * 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) setOption falsestr(fromStr falsestr) +- 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 return $ FormElm [hfs `attrs` attribs] mx +--- _ -> error $ "operator 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") getPassword (fromStr " password again" ++> getPassword View view m (Maybe (UserStr,PasswdStr), Maybe String) +-userLogin= +- ((,) <$> fromStr "Enter User: " ++> getString Nothing fromStr " Enter Pass: " ++> getPassword (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) setOption falsestr(fromStr falsestr) ++ 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 return $ FormElm [hfs `attrs` attribs] mx ++-- _ -> error $ "operator 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") getPassword (fromStr " password again" ++> getPassword View view m (Maybe (UserStr,PasswdStr), Maybe String) ++userLogin= ++ ((,) <$> fromStr "Enter User: " ++> getString Nothing fromStr " Enter Pass: " ++> getPassword (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) (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 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) (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 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 +-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 ++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 + -} +- ++ + 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 -> ""++s ++", ") 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 and +-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 and ++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[ "
"++ 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[ "
"++ 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= +- "

Error 404: Page not found or error ocurred

" <> msg <>"

" <> +- "
" <> opts <> "
press here to go home" +- +- +- paths= Prelude.map B.pack . M.keys $ unsafePerformIO getMessageFlows +- opts= "options: " <> B.concat (Prelude.map (\s -> +- " s <>"\">"<> s <>", ") $ 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= ++ "

Error 404: Page not found or error ocurred

" <> msg <>"

" <> ++ "
" <> opts <> "
press here to go home" ++ ++ ++ paths= Prelude.map B.pack . M.keys $ unsafePerformIO getMessageFlows ++ opts= "options: " <> B.concat (Prelude.map (\s -> ++ " s <>"\">"<> s <>", ") $ 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") ++ ++ ] ++