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") + + ] +