diff --git a/patching/patches/BiobaseTurner-0.3.1.1.patch b/patching/patches/BiobaseTurner-0.3.1.1.patch deleted file mode 100644 index 935dbad4..00000000 --- a/patching/patches/BiobaseTurner-0.3.1.1.patch +++ /dev/null @@ -1,23 +0,0 @@ -diff -ru orig/Biobase/Turner/Import.hs new/Biobase/Turner/Import.hs ---- orig/Biobase/Turner/Import.hs 2014-04-03 10:53:56.310194793 +0300 -+++ new/Biobase/Turner/Import.hs 2014-04-03 10:53:56.000000000 +0300 -@@ -37,6 +37,7 @@ - module Biobase.Turner.Import where - - import Control.Arrow -+import Control.Monad.Trans.Resource (runResourceT) - import Data.Array.Repa.Index - import Data.ByteString.Char8 as BS - import Data.ByteString.Lex.Double -diff -ru orig/BiobaseTurner.cabal new/BiobaseTurner.cabal ---- orig/BiobaseTurner.cabal 2014-04-03 10:53:56.310194793 +0300 -+++ new/BiobaseTurner.cabal 2014-04-03 10:53:56.000000000 +0300 -@@ -35,6 +35,8 @@ - bytestring >= 0.9 , - bytestring-lexing >= 0.4 , - conduit >= 0.5 , -+ conduit-extra >= 1.0 , -+ resourcet >= 0.4 , - containers >= 0.4 , - filepath >= 1 , - lens >= 3.8 , diff --git a/patching/patches/BlogLiterately-diagrams-0.1.4.2.patch b/patching/patches/BlogLiterately-diagrams-0.1.4.2.patch deleted file mode 100644 index 3b645959..00000000 --- a/patching/patches/BlogLiterately-diagrams-0.1.4.2.patch +++ /dev/null @@ -1,15 +0,0 @@ -diff -ru orig/BlogLiterately-diagrams.cabal new/BlogLiterately-diagrams.cabal ---- orig/BlogLiterately-diagrams.cabal 2014-06-03 16:05:19.882144431 +0300 -+++ new/BlogLiterately-diagrams.cabal 2014-06-03 16:05:19.000000000 +0300 -@@ -79,9 +79,9 @@ - containers, - filepath, - directory, -- diagrams-cairo >= 1.0.1 && < 1.2, -+ diagrams-cairo >= 1.0.1 && < 1.3, - diagrams-builder >= 0.5 && < 0.6, -- diagrams-lib >= 1.0.1 && < 1.2, -+ diagrams-lib >= 1.0.1 && < 1.3, - BlogLiterately >= 0.6 && < 0.8, - pandoc >= 1.9 && < 1.13, - safe ==0.3.* diff --git a/patching/patches/ChasingBottoms-1.3.0.7.patch b/patching/patches/ChasingBottoms-1.3.0.7.patch deleted file mode 100644 index a3f7c871..00000000 --- a/patching/patches/ChasingBottoms-1.3.0.7.patch +++ /dev/null @@ -1,34 +0,0 @@ -diff -ru orig/ChasingBottoms.cabal new/ChasingBottoms.cabal ---- orig/ChasingBottoms.cabal 2014-06-10 13:09:03.210534172 +0300 -+++ new/ChasingBottoms.cabal 2014-06-10 13:09:03.000000000 +0300 -@@ -121,7 +121,7 @@ - - other-modules: Test.ChasingBottoms.IsType - -- build-depends: QuickCheck >= 2.1 && < 2.7, -+ build-depends: QuickCheck >= 2.1 && < 2.8, - mtl >= 1.1 && < 2.2, - base >= 4.0 && < 4.8, - containers >= 0.3 && < 0.6, -@@ -150,7 +150,7 @@ - Test.ChasingBottoms.TestUtilities.Generators, - Test.ChasingBottoms.TimeOut.Tests - -- build-depends: QuickCheck >= 2.1 && < 2.7, -+ build-depends: QuickCheck >= 2.1 && < 2.8, - mtl >= 1.1 && < 2.2, - base >= 4.0 && < 4.8, - containers >= 0.3 && < 0.6, -diff -ru orig/Test/ChasingBottoms/ContinuousFunctions.hs new/Test/ChasingBottoms/ContinuousFunctions.hs ---- orig/Test/ChasingBottoms/ContinuousFunctions.hs 2014-06-10 13:09:03.202534172 +0300 -+++ new/Test/ChasingBottoms/ContinuousFunctions.hs 2014-06-10 13:09:03.000000000 +0300 -@@ -143,7 +143,8 @@ - , listOf - ) where - --import Test.QuickCheck hiding ((><), listOf) -+import Test.QuickCheck hiding ((><), listOf, infiniteListOf) -+import Test.QuickCheck.Gen.Unsafe (promote) - import Data.Sequence as Seq - import Data.Foldable as Seq (foldr) - import Prelude as P hiding (concat) diff --git a/patching/patches/MFlow-0.4.5.4.patch b/patching/patches/MFlow-0.4.5.4.patch deleted file mode 100644 index 56eef4bb..00000000 --- a/patching/patches/MFlow-0.4.5.4.patch +++ /dev/null @@ -1,13157 +0,0 @@ -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") -+ -+ ] -+ diff --git a/patching/patches/MusicBrainz-0.2.1.patch b/patching/patches/MusicBrainz-0.2.1.patch deleted file mode 100644 index 8f7fe545..00000000 --- a/patching/patches/MusicBrainz-0.2.1.patch +++ /dev/null @@ -1,28 +0,0 @@ -diff -ru orig/MusicBrainz.cabal new/MusicBrainz.cabal ---- orig/MusicBrainz.cabal 2014-06-30 16:08:08.987902131 +0300 -+++ new/MusicBrainz.cabal 2014-06-30 16:08:08.000000000 +0300 -@@ -23,8 +23,10 @@ - , monad-control ==0.3.* - , bytestring - , conduit >= 1.0.0 -+ , conduit-extra >= 1.0.0 - , text - , time -+ , resourcet - , vector >=0.9 - , xml-types ==0.3.* - , http-conduit >= 1.8.8 -diff -ru orig/Network/Protocol/MusicBrainz/XML2/WebService.hs new/Network/Protocol/MusicBrainz/XML2/WebService.hs ---- orig/Network/Protocol/MusicBrainz/XML2/WebService.hs 2014-06-30 16:08:08.987902131 +0300 -+++ new/Network/Protocol/MusicBrainz/XML2/WebService.hs 2014-06-30 16:08:08.000000000 +0300 -@@ -11,8 +11,9 @@ - import Control.Applicative (liftA2, (<|>)) - import Control.Monad.IO.Class (MonadIO) - import Control.Monad.Trans.Control (MonadBaseControl) -+import Control.Monad.Trans.Resource (MonadThrow, runResourceT) - import qualified Data.ByteString.Lazy as BL --import Data.Conduit (Consumer, ($=), ($$), MonadThrow, runResourceT) -+import Data.Conduit (Consumer, ($=), ($$)) - import Data.Conduit.Binary (sourceLbs) - import Data.List (intercalate) - import Data.Maybe (fromMaybe) diff --git a/patching/patches/Octree-0.5.2.patch b/patching/patches/Octree-0.5.2.patch deleted file mode 100644 index e9414bf6..00000000 --- a/patching/patches/Octree-0.5.2.patch +++ /dev/null @@ -1,19 +0,0 @@ -diff -ru orig/Octree.cabal new/Octree.cabal ---- orig/Octree.cabal 2014-04-17 19:22:31.263672240 +0300 -+++ new/Octree.cabal 2014-04-17 19:22:31.000000000 +0300 -@@ -32,13 +32,13 @@ - - Test-suite test_Octree - Type: exitcode-stdio-1.0 -- Build-depends: base>=4.0 && < 4.7, AC-Vector >= 2.3.0, QuickCheck >= 2.4.0 -+ Build-depends: base>=4.0 && < 4.8, AC-Vector >= 2.3.0, QuickCheck >= 2.4.0 - Main-is: tests/test_Octree.hs - - Test-suite readme - type: exitcode-stdio-1.0 - -- We have a symlink: README.lhs -> README.md - main-is: README.lhs -- Build-depends: base>=4.0 && < 4.7, AC-Vector >= 2.3.0, QuickCheck >= 2.4.0, markdown-unlit -+ Build-depends: base>=4.0 && < 4.8, AC-Vector >= 2.3.0, QuickCheck >= 2.4.0, markdown-unlit - ghc-options: -pgmL markdown-unlit - diff --git a/patching/patches/Octree-0.5.3.patch b/patching/patches/Octree-0.5.3.patch deleted file mode 100644 index 8ac6e50a..00000000 --- a/patching/patches/Octree-0.5.3.patch +++ /dev/null @@ -1,19 +0,0 @@ -diff -ru orig/Octree.cabal new/Octree.cabal ---- orig/Octree.cabal 2014-05-01 18:10:50.650819156 +0300 -+++ new/Octree.cabal 2014-05-01 18:10:50.000000000 +0300 -@@ -33,13 +33,13 @@ - - Test-suite test_Octree - Type: exitcode-stdio-1.0 -- Build-depends: base>=4.0 && < 4.7, AC-Vector >= 2.3.0, QuickCheck >= 2.4.0 -+ Build-depends: base>=4.0 && < 4.8, AC-Vector >= 2.3.0, QuickCheck >= 2.4.0 - Main-is: tests/test_Octree.hs - - Test-suite readme - type: exitcode-stdio-1.0 - -- We have a symlink: README.lhs -> README.md - main-is: README.lhs -- Build-depends: base>=4.0 && < 4.7, AC-Vector >= 2.3.0, QuickCheck >= 2.4.0, markdown-unlit -+ Build-depends: base>=4.0 && < 4.8, AC-Vector >= 2.3.0, QuickCheck >= 2.4.0, markdown-unlit - ghc-options: -pgmL markdown-unlit - diff --git a/patching/patches/arbtt-0.8.1.patch b/patching/patches/arbtt-0.8.1.patch deleted file mode 100644 index ae10d6fd..00000000 --- a/patching/patches/arbtt-0.8.1.patch +++ /dev/null @@ -1,30 +0,0 @@ -diff -ruN orig/arbtt.cabal new/arbtt.cabal ---- orig/arbtt.cabal 2014-08-10 08:32:58.666725004 +0300 -+++ new/arbtt.cabal 2014-08-10 08:32:58.000000000 +0300 -@@ -35,7 +35,7 @@ - build-depends: - base == 4.5.* || == 4.6.* || == 4.7.*, - filepath, directory, transformers, time >= 1.4, utf8-string, -- aeson == 0.6.* || == 0.7.*, -+ aeson, - array == 0.4.* || == 0.5.*, - binary >= 0.5, - bytestring, deepseq, strict, old-locale -@@ -82,7 +82,7 @@ - binary >= 0.5, - deepseq, bytestring, utf8-string, time >= 1.4, strict, - transformers, unix, directory, filepath, -- aeson == 0.6.* || == 0.7.*, -+ aeson, - array == 0.4.* || == 0.5.*, - terminal-progress-bar, bytestring-progress - other-modules: -@@ -112,7 +112,7 @@ - base == 4.5.* || == 4.6.* || == 4.7.*, - parsec == 3.*, - containers == 0.5.*, -- aeson == 0.6.* || == 0.7.*, -+ aeson, - array == 0.4.* || == 0.5.*, - binary >= 0.5, - deepseq, bytestring, utf8-string, time >= 1.4, strict, diff --git a/patching/patches/async-2.0.1.5.patch b/patching/patches/async-2.0.1.5.patch deleted file mode 100644 index 2c301317..00000000 --- a/patching/patches/async-2.0.1.5.patch +++ /dev/null @@ -1,40 +0,0 @@ -diff -ruN orig/Control/Concurrent/Async.hs new/Control/Concurrent/Async.hs ---- orig/Control/Concurrent/Async.hs 2014-08-11 12:23:17.688591763 +0300 -+++ new/Control/Concurrent/Async.hs 2014-08-11 12:23:17.000000000 +0300 -@@ -246,7 +246,10 @@ - -- - {-# INLINE waitCatch #-} - waitCatch :: Async a -> IO (Either SomeException a) --waitCatch = atomically . waitCatchSTM -+waitCatch = tryAgain . atomically . waitCatchSTM -+ where -+ -- See: https://github.com/simonmar/async/issues/14 -+ tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f - - -- | Check whether an 'Async' has completed yet. If it has not - -- completed yet, then the result is @Nothing@, otherwise the result -diff -ruN orig/test/test-async.hs new/test/test-async.hs ---- orig/test/test-async.hs 2014-08-11 12:23:17.688591763 +0300 -+++ new/test/test-async.hs 2014-08-11 12:23:17.000000000 +0300 -@@ -29,6 +29,7 @@ - testCase "async_cancel" async_cancel - , testCase "async_poll" async_poll - , testCase "async_poll2" async_poll2 -+ , testCase "withasync_waitCatch_blocked" withasync_waitCatch_blocked - ] - - value = 42 :: Int -@@ -104,3 +105,13 @@ - when (isNothing r) $ assertFailure "" - r <- poll a -- poll twice, just to check we don't deadlock - when (isNothing r) $ assertFailure "" -+ -+withasync_waitCatch_blocked :: Assertion -+withasync_waitCatch_blocked = do -+ r <- withAsync (newEmptyMVar >>= takeMVar) waitCatch -+ case r of -+ Left e -> -+ case fromException e of -+ Just BlockedIndefinitelyOnMVar -> return () -+ Nothing -> assertFailure $ show e -+ Right () -> assertFailure "" diff --git a/patching/patches/authenticate-oauth-1.4.0.8.patch b/patching/patches/authenticate-oauth-1.4.0.8.patch deleted file mode 100644 index d079260e..00000000 --- a/patching/patches/authenticate-oauth-1.4.0.8.patch +++ /dev/null @@ -1,147 +0,0 @@ -diff -ru orig/authenticate-oauth.cabal new/authenticate-oauth.cabal ---- orig/authenticate-oauth.cabal 2014-02-21 07:19:28.878548521 +0200 -+++ new/authenticate-oauth.cabal 2014-02-21 07:19:28.000000000 +0200 -@@ -19,7 +19,7 @@ - , transformers >= 0.1 && < 0.4 - , bytestring >= 0.9 - , crypto-pubkey-types >= 0.1 && < 0.5 -- , RSA >= 1.2 && < 1.3 -+ , RSA >= 1.2 && < 2.1 - , time - , data-default - , base64-bytestring >= 0.1 && < 1.1 -diff -ru orig/Web/Authenticate/OAuth.hs new/Web/Authenticate/OAuth.hs ---- orig/Web/Authenticate/OAuth.hs 2014-02-21 07:19:28.874548521 +0200 -+++ new/Web/Authenticate/OAuth.hs 2014-02-21 07:19:28.000000000 +0200 -@@ -1,5 +1,5 @@ --{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, MultiParamTypeClasses #-} --{-# LANGUAGE OverloadedStrings, StandaloneDeriving #-} -+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving, FlexibleContexts #-} -+{-# LANGUAGE CPP #-} - {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} - module Web.Authenticate.OAuth - ( -- * Data types -@@ -15,48 +15,50 @@ - authorizeUrl, authorizeUrl', getAccessToken, getTemporaryCredential, - getTokenCredential, getTemporaryCredentialWithScope, - getAccessTokenProxy, getTemporaryCredentialProxy, -- getTokenCredentialProxy, -+ getTokenCredentialProxy, - getAccessToken', getTemporaryCredential', - -- * Utility Methods - paramEncode, addScope, addMaybeProxy - ) where --import Blaze.ByteString.Builder (toByteString, Builder) --import Codec.Crypto.RSA (ha_SHA1, rsassa_pkcs1_v1_5_sign) --import Control.Exception --import Control.Monad --import Control.Monad.IO.Class (MonadIO, liftIO) --import Control.Monad.Trans.Control --import Control.Monad.Trans.Resource --import Crypto.Types.PubKey.RSA (PrivateKey (..), PublicKey (..)) --import Data.ByteString.Base64 --import qualified Data.ByteString.Char8 as BS --import qualified Data.ByteString.Lazy.Char8 as BSL --import Data.Char --import Data.Conduit (Source, ($$), ($=)) --import Data.Conduit.Blaze (builderToByteString) --import qualified Data.Conduit.List as CL --import Data.Default --import Data.Digest.Pure.SHA --import qualified Data.IORef as I --import Data.List (sortBy) --import Data.Maybe --import Data.Time --import Network.HTTP.Conduit --import Network.HTTP.Types (SimpleQuery, parseSimpleQuery) --import Network.HTTP.Types (Header) --import Network.HTTP.Types (renderSimpleQuery, status200) --import Numeric --import System.Random --#if MIN_VERSION_base(4,7,0) --import Data.Data hiding (Proxy (..)) --#else -+import Network.HTTP.Conduit - import Data.Data -+import qualified Data.ByteString.Char8 as BS -+import qualified Data.ByteString.Lazy.Char8 as BSL -+import Data.Maybe -+import Network.HTTP.Types (parseSimpleQuery, SimpleQuery) -+import Control.Exception -+import Control.Monad -+import Data.List (sortBy) -+import System.Random -+import Data.Char -+import Data.Digest.Pure.SHA -+import Data.ByteString.Base64 -+import Data.Time -+import Numeric -+#if MIN_VERSION_RSA(2, 0, 0) -+import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, hashSHA1) -+#else -+import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, ha_SHA1) - #endif -+import Crypto.Types.PubKey.RSA (PrivateKey(..), PublicKey(..)) -+import Network.HTTP.Types (Header) -+import Blaze.ByteString.Builder (toByteString) -+import Control.Monad.IO.Class (MonadIO) -+import Network.HTTP.Types (renderSimpleQuery, status200) -+import Data.Conduit (($$), ($=), Source) -+import qualified Data.Conduit.List as CL -+import Data.Conduit.Blaze (builderToByteString) -+import Blaze.ByteString.Builder (Builder) -+import Control.Monad.IO.Class (liftIO) -+import Control.Monad.Trans.Control -+import Control.Monad.Trans.Resource -+import Data.Default -+import qualified Data.IORef as I - - -- | Data type for OAuth client (consumer). ---- ---- The constructor for this data type is not exposed. ---- Instead, you should use the 'def' method or 'newOAuth' function to retrieve a default instance, -+-- -+-- The constructor for this data type is not exposed. -+-- Instead, you should use the 'def' method or 'newOAuth' function to retrieve a default instance, - -- and then use the records below to make modifications. - -- This approach allows us to add configuration options without breaking backwards compatibility. - data OAuth = OAuth { oauthServerName :: String -- ^ Service name (default: @\"\"@) -@@ -71,7 +73,7 @@ - , oauthAuthorizeUri :: String - -- ^ Uri to authorize (default: @\"\"@). - -- You MUST specify if you use 'authorizeUrl' or 'authorizeZUrl''; -- -- otherwise you can just leave this empty. -+ -- otherwise you can just leave this empty. - , oauthSignatureMethod :: SignMethod - -- ^ Signature Method (default: 'HMACSHA1') - , oauthConsumerKey :: BS.ByteString -@@ -188,7 +190,7 @@ - getTemporaryCredential' hook oa manager = do - let req = fromJust $ parseUrl $ oauthRequestUri oa - crd = maybe id (insert "oauth_callback") (oauthCallback oa) $ emptyCredential -- req' <- signOAuth oa crd $ hook (req { method = "POST" }) -+ req' <- signOAuth oa crd $ hook (req { method = "POST" }) - rsp <- httpLbs req' manager - if responseStatus rsp == status200 - then do -@@ -211,7 +213,7 @@ - -> String -- ^ URL to authorize - authorizeUrl' f oa cr = oauthAuthorizeUri oa ++ BS.unpack (renderSimpleQuery True queries) - where fixed = ("oauth_token", token cr):f oa cr -- queries = -+ queries = - case oauthCallback oa of - Nothing -> fixed - Just callback -> ("oauth_callback", callback):fixed -@@ -346,7 +348,11 @@ - PLAINTEXT -> - return $ BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok] - RSASHA1 pr -> -+#if MIN_VERSION_RSA(2, 0, 0) -+ liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign hashSHA1 pr) (getBaseString tok req) -+#else - liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign ha_SHA1 pr) (getBaseString tok req) -+#endif - - #if MIN_VERSION_http_conduit(2, 0, 0) - addAuthHeader :: BS.ByteString -> Credential -> Request -> Request diff --git a/patching/patches/aws-0.8.6.patch b/patching/patches/aws-0.8.6.patch deleted file mode 100644 index bac8604e..00000000 --- a/patching/patches/aws-0.8.6.patch +++ /dev/null @@ -1,596 +0,0 @@ -diff -ru orig/Aws/Aws.hs new/Aws/Aws.hs ---- orig/Aws/Aws.hs 2014-04-04 10:18:25.108401067 +0300 -+++ new/Aws/Aws.hs 2014-04-04 10:18:24.000000000 +0300 -@@ -33,7 +33,6 @@ - import Control.Monad.IO.Class - import Control.Monad.Trans - import Control.Monad.Trans.Resource --import Data.Attempt (Attempt(Success, Failure)) - import qualified Data.ByteString as B - import qualified Data.CaseInsensitive as CI - import qualified Data.Conduit as C -@@ -185,11 +184,8 @@ - unsafeAws cfg scfg manager request = do - metadataRef <- liftIO $ newIORef mempty - -- let catchAll :: ResourceT IO a -> ResourceT IO (Attempt a) -- catchAll = E.handle (return . failure') . fmap Success -- -- failure' :: E.SomeException -> Attempt a -- failure' = Failure -+ let catchAll :: ResourceT IO a -> ResourceT IO (Either E.SomeException a) -+ catchAll = E.handle (return . Left) . fmap Right - - resp <- catchAll $ - unsafeAwsRef cfg scfg manager metadataRef request -@@ -268,8 +264,8 @@ - where go request = do resp <- lift $ aws cfg scfg manager request - C.yield resp - case responseResult resp of -- Failure _ -> return () -- Success x -> -+ Left _ -> return () -+ Right x -> - case nextIteratedRequest request x of - Nothing -> return () - Just nextRequest -> go nextRequest -diff -ru orig/Aws/Core.hs new/Aws/Core.hs ---- orig/Aws/Core.hs 2014-04-04 10:18:25.108401067 +0300 -+++ new/Aws/Core.hs 2014-04-04 10:18:24.000000000 +0300 -@@ -89,13 +89,12 @@ - import Control.Applicative - import Control.Arrow - import qualified Control.Exception as E --import qualified Control.Failure as F - import Control.Monad - import Control.Monad.IO.Class -+import Control.Monad.Trans.Resource (ResourceT, MonadThrow (throwM)) - import qualified Crypto.Classes as Crypto - import qualified Crypto.HMAC as HMAC - import Crypto.Hash.CryptoAPI (MD5, SHA1, SHA256, hash') --import Data.Attempt (Attempt(..), FromAttempt(..)) - import Data.ByteString (ByteString) - import qualified Data.ByteString as B - import qualified Data.ByteString.Base16 as Base16 -@@ -104,7 +103,7 @@ - import qualified Data.ByteString.Lazy as L - import qualified Data.ByteString.UTF8 as BU - import Data.Char --import Data.Conduit (ResourceT, ($$+-)) -+import Data.Conduit (($$+-)) - import qualified Data.Conduit as C - import qualified Data.Conduit.List as CL - import Data.Default (def) -@@ -137,12 +136,12 @@ - -- - -- Response forms a Writer-like monad. - data Response m a = Response { responseMetadata :: m -- , responseResult :: Attempt a } -+ , responseResult :: Either E.SomeException a } - deriving (Show, Functor) - - -- | Read a response result (if it's a success response, fail otherwise). --readResponse :: FromAttempt f => Response m a -> f a --readResponse = fromAttempt . responseResult -+readResponse :: MonadThrow n => Response m a -> n a -+readResponse = either throwM return . responseResult - - -- | Read a response result (if it's a success response, fail otherwise). In MonadIO. - readResponseIO :: MonadIO io => Response m a -> io a -@@ -159,13 +158,13 @@ - --multiResponse :: Monoid m => Response m a -> Response [m] a -> - - instance Monoid m => Monad (Response m) where -- return x = Response mempty (Success x) -- Response m1 (Failure e) >>= _ = Response m1 (Failure e) -- Response m1 (Success x) >>= f = let Response m2 y = f x -+ return x = Response mempty (Right x) -+ Response m1 (Left e) >>= _ = Response m1 (Left e) -+ Response m1 (Right x) >>= f = let Response m2 y = f x - in Response (m1 `mappend` m2) y -- currently using First-semantics, Last SHOULD work too - --instance (Monoid m, E.Exception e) => F.Failure e (Response m) where -- failure e = Response mempty (F.failure e) -+instance Monoid m => MonadThrow (Response m) where -+ throwM e = Response mempty (throwM e) - - -- | Add metadata to an 'IORef' (using 'mappend'). - tellMetadataRef :: Monoid m => IORef m -> m -> IO () -@@ -696,24 +695,24 @@ - elCont name = laxElement name &/ content &| T.unpack - - -- | Extract the first element from a parser result list, and throw an 'XmlException' if the list is empty. --force :: F.Failure XmlException m => String -> [a] -> m a -+force :: MonadThrow m => String -> [a] -> m a - force = Cu.force . XmlException - - -- | Extract the first element from a monadic parser result list, and throw an 'XmlException' if the list is empty. --forceM :: F.Failure XmlException m => String -> [m a] -> m a -+forceM :: MonadThrow m => String -> [m a] -> m a - forceM = Cu.forceM . XmlException - - -- | Read an integer from a 'T.Text', throwing an 'XmlException' on failure. --textReadInt :: (F.Failure XmlException m, Num a) => T.Text -> m a -+textReadInt :: (MonadThrow m, Num a) => T.Text -> m a - textReadInt s = case reads $ T.unpack s of - [(n,"")] -> return $ fromInteger n -- _ -> F.failure $ XmlException "Invalid Integer" -+ _ -> throwM $ XmlException "Invalid Integer" - - -- | Read an integer from a 'String', throwing an 'XmlException' on failure. --readInt :: (F.Failure XmlException m, Num a) => String -> m a -+readInt :: (MonadThrow m, Num a) => String -> m a - readInt s = case reads s of - [(n,"")] -> return $ fromInteger n -- _ -> F.failure $ XmlException "Invalid Integer" -+ _ -> throwM $ XmlException "Invalid Integer" - - -- | Create a complete 'HTTPResponseConsumer' from a simple function that takes a 'Cu.Cursor' to XML in the response - -- body. -@@ -731,5 +730,5 @@ - let Response metadata x = parse cursor - liftIO $ tellMetadataRef metadataRef metadata - case x of -- Failure err -> liftIO $ C.monadThrow err -- Success v -> return v -+ Left err -> liftIO $ throwM err -+ Right v -> return v -diff -ru orig/Aws/DynamoDb/Core.hs new/Aws/DynamoDb/Core.hs ---- orig/Aws/DynamoDb/Core.hs 2014-04-04 10:18:25.108401067 +0300 -+++ new/Aws/DynamoDb/Core.hs 2014-04-04 10:18:24.000000000 +0300 -@@ -2,6 +2,7 @@ - - import Aws.Core - import qualified Control.Exception as C -+import Control.Monad.Trans.Resource (throwM) - import Crypto.Hash.CryptoAPI (SHA256, hash) - import qualified Data.Aeson as A - import qualified Data.ByteString as B -@@ -125,5 +126,5 @@ - (HTTP.Status{HTTP.statusCode=200}) -> do - case A.fromJSON val of - A.Success a -> return a -- A.Error err -> monadThrow $ DyError (HTTP.responseStatus resp) "" err -- _ -> monadThrow $ DyError (HTTP.responseStatus resp) "" (show val) -+ A.Error err -> throwM $ DyError (HTTP.responseStatus resp) "" err -+ _ -> throwM $ DyError (HTTP.responseStatus resp) "" (show val) -diff -ru orig/Aws/Ec2/InstanceMetadata.hs new/Aws/Ec2/InstanceMetadata.hs ---- orig/Aws/Ec2/InstanceMetadata.hs 2014-04-04 10:18:25.112401067 +0300 -+++ new/Aws/Ec2/InstanceMetadata.hs 2014-04-04 10:18:24.000000000 +0300 -@@ -2,7 +2,7 @@ - - import Control.Applicative - import Control.Exception --import Control.Failure -+import Control.Monad.Trans.Resource (throwM) - import qualified Data.ByteString.Lazy as L - import qualified Data.ByteString.Lazy.Char8 as B8 - import Data.ByteString.Lazy.UTF8 as BU -@@ -25,7 +25,7 @@ - getInstanceMetadataFirst :: HTTP.Manager -> String -> IO L.ByteString - getInstanceMetadataFirst mgr p = do listing <- getInstanceMetadataListing mgr p - case listing of -- [] -> failure (MetadataNotFound p) -+ [] -> throwM (MetadataNotFound p) - (x:_) -> getInstanceMetadata mgr p x - - getInstanceMetadataOrFirst :: HTTP.Manager -> String -> Maybe String -> IO L.ByteString -diff -ru orig/Aws/Iam/Core.hs new/Aws/Iam/Core.hs ---- orig/Aws/Iam/Core.hs 2014-04-04 10:18:25.112401067 +0300 -+++ new/Aws/Iam/Core.hs 2014-04-04 10:18:24.000000000 +0300 -@@ -19,8 +19,8 @@ - import qualified Blaze.ByteString.Builder as Blaze - import qualified Blaze.ByteString.Builder.Char8 as Blaze8 - import Control.Exception (Exception) --import qualified Control.Failure as F - import Control.Monad -+import Control.Monad.Trans.Resource (MonadThrow, throwM) - import Data.ByteString (ByteString) - import Data.IORef - import Data.List (intersperse, sort) -@@ -152,13 +152,13 @@ - fromError cursor = do - errCode <- force "Missing Error Code" $ cursor $// elContent "Code" - errMsg <- force "Missing Error Message" $ cursor $// elContent "Message" -- F.failure $ IamError (HTTP.responseStatus resp) errCode errMsg -+ throwM $ IamError (HTTP.responseStatus resp) errCode errMsg - - -- | Parses IAM @DateTime@ data type. --parseDateTime :: (F.Failure XmlException m) => String -> m UTCTime -+parseDateTime :: MonadThrow m => String -> m UTCTime - parseDateTime x - = case parseTime defaultTimeLocale iso8601UtcDate x of -- Nothing -> F.failure $ XmlException $ "Invalid DateTime: " ++ x -+ Nothing -> throwM $ XmlException $ "Invalid DateTime: " ++ x - Just dt -> return dt - - -- | The IAM @User@ data type. -@@ -180,7 +180,7 @@ - deriving (Eq, Ord, Show, Typeable) - - -- | Parses the IAM @User@ data type. --parseUser :: (F.Failure XmlException m) => Cu.Cursor -> m User -+parseUser :: MonadThrow m => Cu.Cursor -> m User - parseUser cursor = do - userArn <- attr "Arn" - userCreateDate <- attr "CreateDate" >>= parseDateTime . Text.unpack -diff -ru orig/Aws/Iam/Internal.hs new/Aws/Iam/Internal.hs ---- orig/Aws/Iam/Internal.hs 2014-04-04 10:18:25.112401067 +0300 -+++ new/Aws/Iam/Internal.hs 2014-04-04 10:18:24.000000000 +0300 -@@ -15,8 +15,8 @@ - import Aws.Iam.Core - import Control.Applicative - import Control.Arrow (second) --import qualified Control.Failure as F - import Control.Monad -+import Control.Monad.Trans.Resource (MonadThrow) - import Data.ByteString (ByteString) - import Data.Maybe - import Data.Monoid ((<>)) -@@ -62,7 +62,7 @@ - -- | Reads and returns the @IsTruncated@ and @Marker@ attributes present in - -- all IAM data pagination responses. - markedIterResponse -- :: F.Failure XmlException m -+ :: MonadThrow m - => Cu.Cursor - -> m (Bool, Maybe Text) - markedIterResponse cursor = do -diff -ru orig/Aws/S3/Commands/CopyObject.hs new/Aws/S3/Commands/CopyObject.hs ---- orig/Aws/S3/Commands/CopyObject.hs 2014-04-04 10:18:25.112401067 +0300 -+++ new/Aws/S3/Commands/CopyObject.hs 2014-04-04 10:18:24.000000000 +0300 -@@ -5,7 +5,7 @@ - import Aws.S3.Core - import Control.Applicative - import Control.Arrow (second) --import Control.Failure -+import Control.Monad.Trans.Resource (throwM) - import qualified Data.CaseInsensitive as CI - import Data.Maybe - import qualified Data.Text as T -@@ -93,7 +93,7 @@ - return $ CopyObjectResponse vid lastMod etag - where parse el = do - let parseHttpDate' x = case parseTime defaultTimeLocale iso8601UtcDate x of -- Nothing -> failure $ XmlException ("Invalid Last-Modified " ++ x) -+ Nothing -> throwM $ XmlException ("Invalid Last-Modified " ++ x) - Just y -> return y - lastMod <- forceM "Missing Last-Modified" $ el $/ elContent "LastModified" &| (parseHttpDate' . T.unpack) - etag <- force "Missing ETag" $ el $/ elContent "ETag" -diff -ru orig/Aws/S3/Core.hs new/Aws/S3/Core.hs ---- orig/Aws/S3/Core.hs 2014-04-04 10:18:25.112401067 +0300 -+++ new/Aws/S3/Core.hs 2014-04-04 10:18:24.000000000 +0300 -@@ -5,8 +5,8 @@ - import Control.Arrow ((***)) - import Control.Monad - import Control.Monad.IO.Class -+import Control.Monad.Trans.Resource (MonadThrow, throwM) - import Crypto.Hash.CryptoAPI (MD5) --import Data.Attempt (Attempt(..)) - import Data.Conduit (($$+-)) - import Data.Function - import Data.IORef -@@ -20,12 +20,10 @@ - import qualified Blaze.ByteString.Builder as Blaze - import qualified Blaze.ByteString.Builder.Char8 as Blaze8 - import qualified Control.Exception as C --import qualified Control.Failure as F - import qualified Data.ByteString as B - import qualified Data.ByteString.Char8 as B8 - import qualified Data.ByteString.Base64 as Base64 - import qualified Data.CaseInsensitive as CI --import qualified Data.Conduit as C - import qualified Data.Serialize as Serialize - import qualified Data.Text as T - import qualified Data.Text.Encoding as T -@@ -248,10 +246,10 @@ - = do doc <- HTTP.responseBody resp $$+- XML.sinkDoc XML.def - let cursor = Cu.fromDocument doc - liftIO $ case parseError cursor of -- Success err -> C.monadThrow err -- Failure otherErr -> C.monadThrow otherErr -+ Right err -> throwM err -+ Left otherErr -> throwM otherErr - where -- parseError :: Cu.Cursor -> Attempt S3Error -+ parseError :: Cu.Cursor -> Either C.SomeException S3Error - parseError root = do code <- force "Missing error Code" $ root $/ elContent "Code" - message <- force "Missing error Message" $ root $/ elContent "Message" - let resource = listToMaybe $ root $/ elContent "Resource" -@@ -279,7 +277,7 @@ - } - deriving (Show) - --parseUserInfo :: F.Failure XmlException m => Cu.Cursor -> m UserInfo -+parseUserInfo :: MonadThrow m => Cu.Cursor -> m UserInfo - parseUserInfo el = do id_ <- force "Missing user ID" $ el $/ elContent "ID" - displayName <- force "Missing user DisplayName" $ el $/ elContent "DisplayName" - return UserInfo { userId = id_, userDisplayName = displayName } -@@ -308,10 +306,10 @@ - | ReducedRedundancy - deriving (Show) - --parseStorageClass :: F.Failure XmlException m => T.Text -> m StorageClass -+parseStorageClass :: MonadThrow m => T.Text -> m StorageClass - parseStorageClass "STANDARD" = return Standard - parseStorageClass "REDUCED_REDUNDANCY" = return ReducedRedundancy --parseStorageClass s = F.failure . XmlException $ "Invalid Storage Class: " ++ T.unpack s -+parseStorageClass s = throwM . XmlException $ "Invalid Storage Class: " ++ T.unpack s - - writeStorageClass :: StorageClass -> T.Text - writeStorageClass Standard = "STANDARD" -@@ -321,9 +319,9 @@ - = AES256 - deriving (Show) - --parseServerSideEncryption :: F.Failure XmlException m => T.Text -> m ServerSideEncryption -+parseServerSideEncryption :: MonadThrow m => T.Text -> m ServerSideEncryption - parseServerSideEncryption "AES256" = return AES256 --parseServerSideEncryption s = F.failure . XmlException $ "Invalid Server Side Encryption: " ++ T.unpack s -+parseServerSideEncryption s = throwM . XmlException $ "Invalid Server Side Encryption: " ++ T.unpack s - - writeServerSideEncryption :: ServerSideEncryption -> T.Text - writeServerSideEncryption AES256 = "AES256" -@@ -358,11 +356,11 @@ - } - deriving (Show) - --parseObjectInfo :: F.Failure XmlException m => Cu.Cursor -> m ObjectInfo -+parseObjectInfo :: MonadThrow m => Cu.Cursor -> m ObjectInfo - parseObjectInfo el - = do key <- force "Missing object Key" $ el $/ elContent "Key" - let time s = case parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" $ T.unpack s of -- Nothing -> F.failure $ XmlException "Invalid time" -+ Nothing -> throwM $ XmlException "Invalid time" - Just v -> return v - lastModified <- forceM "Missing object LastModified" $ el $/ elContent "LastModified" &| time - eTag <- force "Missing object ETag" $ el $/ elContent "ETag" -@@ -392,7 +390,7 @@ - } - deriving (Show) - --parseObjectMetadata :: F.Failure HeaderException m => HTTP.ResponseHeaders -> m ObjectMetadata -+parseObjectMetadata :: MonadThrow m => HTTP.ResponseHeaders -> m ObjectMetadata - parseObjectMetadata h = ObjectMetadata - `liftM` deleteMarker - `ap` etag -@@ -406,15 +404,15 @@ - Nothing -> return False - Just "true" -> return True - Just "false" -> return False -- Just x -> F.failure $ HeaderException ("Invalid x-amz-delete-marker " ++ x) -+ Just x -> throwM $ HeaderException ("Invalid x-amz-delete-marker " ++ x) - etag = case T.decodeUtf8 `fmap` lookup "ETag" h of - Just x -> return x -- Nothing -> F.failure $ HeaderException "ETag missing" -+ Nothing -> throwM $ HeaderException "ETag missing" - lastModified = case B8.unpack `fmap` lookup "Last-Modified" h of - Just ts -> case parseHttpDate ts of - Just t -> return t -- Nothing -> F.failure $ HeaderException ("Invalid Last-Modified: " ++ ts) -- Nothing -> F.failure $ HeaderException "Last-Modified missing" -+ Nothing -> throwM $ HeaderException ("Invalid Last-Modified: " ++ ts) -+ Nothing -> throwM $ HeaderException "Last-Modified missing" - versionId = T.decodeUtf8 `fmap` lookup "x-amz-version-id" h - -- expiration = return undefined - userMetadata = flip mapMaybe ht $ -diff -ru orig/Aws/Ses/Core.hs new/Aws/Ses/Core.hs ---- orig/Aws/Ses/Core.hs 2014-04-04 10:18:25.112401067 +0300 -+++ new/Aws/Ses/Core.hs 2014-04-04 10:18:24.000000000 +0300 -@@ -22,8 +22,8 @@ - import qualified Blaze.ByteString.Builder as Blaze - import qualified Blaze.ByteString.Builder.Char8 as Blaze8 - import qualified Control.Exception as C --import qualified Control.Failure as F - import Control.Monad (mplus) -+import Control.Monad.Trans.Resource (throwM) - import qualified Data.ByteString as B - import qualified Data.ByteString.Base64 as B64 - import Data.ByteString.Char8 ({-IsString-}) -@@ -128,7 +128,7 @@ - fromError cursor = do - errCode <- force "Missing Error Code" $ cursor $// elContent "Code" - errMessage <- force "Missing Error Message" $ cursor $// elContent "Message" -- F.failure $ SesError (HTTP.responseStatus resp) errCode errMessage -+ throwM $ SesError (HTTP.responseStatus resp) errCode errMessage - - class SesAsQuery a where - -- | Write a data type as a list of query parameters. -diff -ru orig/Aws/SimpleDb/Core.hs new/Aws/SimpleDb/Core.hs ---- orig/Aws/SimpleDb/Core.hs 2014-04-04 10:18:25.116401067 +0300 -+++ new/Aws/SimpleDb/Core.hs 2014-04-04 10:18:24.000000000 +0300 -@@ -4,8 +4,8 @@ - import qualified Blaze.ByteString.Builder as Blaze - import qualified Blaze.ByteString.Builder.Char8 as Blaze8 - import qualified Control.Exception as C --import qualified Control.Failure as F - import Control.Monad -+import Control.Monad.Trans.Resource (MonadThrow, throwM) - import qualified Data.ByteString as B - import qualified Data.ByteString.Base64 as Base64 - import Data.IORef -@@ -149,16 +149,16 @@ - (err:_) -> fromError err - fromError cursor = do errCode <- force "Missing Error Code" $ cursor $// elCont "Code" - errMessage <- force "Missing Error Message" $ cursor $// elCont "Message" -- F.failure $ SdbError (HTTP.responseStatus resp) errCode errMessage -+ throwM $ SdbError (HTTP.responseStatus resp) errCode errMessage - - class SdbFromResponse a where - sdbFromResponse :: Cu.Cursor -> Response SdbMetadata a - --sdbCheckResponseType :: F.Failure XmlException m => a -> T.Text -> Cu.Cursor -> m a -+sdbCheckResponseType :: MonadThrow m => a -> T.Text -> Cu.Cursor -> m a - sdbCheckResponseType a n c = do _ <- force ("Expected response type " ++ T.unpack n) (Cu.laxElement n c) - return a - --decodeBase64 :: F.Failure XmlException m => Cu.Cursor -> m T.Text -+decodeBase64 :: MonadThrow m => Cu.Cursor -> m T.Text - decodeBase64 cursor = - let encoded = T.concat $ cursor $/ Cu.content - encoding = listToMaybe $ cursor $| Cu.laxAttribute "encoding" &| T.toCaseFold -@@ -166,15 +166,15 @@ - case encoding of - Nothing -> return encoded - Just "base64" -> case Base64.decode . T.encodeUtf8 $ encoded of -- Left msg -> F.failure $ XmlException ("Invalid Base64 data: " ++ msg) -+ Left msg -> throwM $ XmlException ("Invalid Base64 data: " ++ msg) - Right x -> return $ T.decodeUtf8 x -- Just actual -> F.failure $ XmlException ("Unrecognized encoding " ++ T.unpack actual) -+ Just actual -> throwM $ XmlException ("Unrecognized encoding " ++ T.unpack actual) - - data Attribute a - = ForAttribute { attributeName :: T.Text, attributeData :: a } - deriving (Show) - --readAttribute :: F.Failure XmlException m => Cu.Cursor -> m (Attribute T.Text) -+readAttribute :: MonadThrow m => Cu.Cursor -> m (Attribute T.Text) - readAttribute cursor = do - name <- forceM "Missing Name" $ cursor $/ Cu.laxElement "Name" &| decodeBase64 - value <- forceM "Missing Value" $ cursor $/ Cu.laxElement "Value" &| decodeBase64 -@@ -225,7 +225,7 @@ - = Item { itemName :: T.Text, itemData :: a } - deriving (Show) - --readItem :: F.Failure XmlException m => Cu.Cursor -> m (Item [Attribute T.Text]) -+readItem :: MonadThrow m => Cu.Cursor -> m (Item [Attribute T.Text]) - readItem cursor = do - name <- force "Missing Name" <=< sequence $ cursor $/ Cu.laxElement "Name" &| decodeBase64 - attributes <- sequence $ cursor $/ Cu.laxElement "Attribute" &| readAttribute -diff -ru orig/Aws/Sqs/Commands/Message.hs new/Aws/Sqs/Commands/Message.hs ---- orig/Aws/Sqs/Commands/Message.hs 2014-04-04 10:18:25.116401067 +0300 -+++ new/Aws/Sqs/Commands/Message.hs 2014-04-04 10:18:24.000000000 +0300 -@@ -4,9 +4,9 @@ - import Aws.Core - import Aws.Sqs.Core - import Control.Applicative -+import Control.Monad.Trans.Resource (MonadThrow) - import Data.Maybe - import Text.XML.Cursor (($/), ($//), (&/), (&|)) --import qualified Control.Failure as F - import qualified Data.ByteString.Char8 as B - import qualified Data.Text as T - import qualified Data.Text.Encoding as TE -@@ -98,7 +98,7 @@ - } - deriving (Show) - --readMessageAttribute :: F.Failure XmlException m => Cu.Cursor -> m (MessageAttribute,T.Text) -+readMessageAttribute :: MonadThrow m => Cu.Cursor -> m (MessageAttribute,T.Text) - readMessageAttribute cursor = do - name <- force "Missing Name" $ cursor $/ Cu.laxElement "Name" &/ Cu.content - value <- force "Missing Value" $ cursor $/ Cu.laxElement "Value" &/ Cu.content -diff -ru orig/Aws/Sqs/Core.hs new/Aws/Sqs/Core.hs ---- orig/Aws/Sqs/Core.hs 2014-04-04 10:18:25.116401067 +0300 -+++ new/Aws/Sqs/Core.hs 2014-04-04 10:18:24.000000000 +0300 -@@ -5,14 +5,12 @@ - import qualified Blaze.ByteString.Builder as Blaze - import qualified Blaze.ByteString.Builder.Char8 as Blaze8 - import qualified Control.Exception as C --import qualified Control.Failure as F - import Control.Monad - import Control.Monad.IO.Class --import Data.Attempt (Attempt(..)) -+import Control.Monad.Trans.Resource (MonadThrow, throwM) - import qualified Data.ByteString as B - import qualified Data.ByteString.Char8 as BC - import Data.Conduit (($$+-)) --import qualified Data.Conduit as C - import Data.IORef - import Data.List - import Data.Maybe -@@ -234,10 +232,10 @@ - = do doc <- HTTP.responseBody resp $$+- XML.sinkDoc XML.def - let cursor = Cu.fromDocument doc - liftIO $ case parseError cursor of -- Success err -> C.monadThrow err -- Failure otherErr -> C.monadThrow otherErr -+ Right err -> throwM err -+ Left otherErr -> throwM otherErr - where -- parseError :: Cu.Cursor -> Attempt SqsError -+ parseError :: Cu.Cursor -> Either C.SomeException SqsError - parseError root = do cursor <- force "Missing Error" $ root $/ Cu.laxElement "Error" - code <- force "Missing error Code" $ cursor $/ elContent "Code" - message <- force "Missing error Message" $ cursor $/ elContent "Message" -@@ -291,7 +289,7 @@ - | PermissionGetQueueAttributes - deriving (Show, Enum, Eq) - --parseQueueAttribute :: F.Failure XmlException m => T.Text -> m QueueAttribute -+parseQueueAttribute :: MonadThrow m => T.Text -> m QueueAttribute - parseQueueAttribute "ApproximateNumberOfMessages" = return ApproximateNumberOfMessages - parseQueueAttribute "ApproximateNumberOfMessagesNotVisible" = return ApproximateNumberOfMessagesNotVisible - parseQueueAttribute "VisibilityTimeout" = return VisibilityTimeout -@@ -301,7 +299,7 @@ - parseQueueAttribute "MaximumMessageSize" = return MaximumMessageSize - parseQueueAttribute "MessageRetentionPeriod" = return MessageRetentionPeriod - parseQueueAttribute "QueueArn" = return QueueArn --parseQueueAttribute x = F.failure $ XmlException ( "Invalid Attribute Name. " ++ show x) -+parseQueueAttribute x = throwM $ XmlException ( "Invalid Attribute Name. " ++ show x) - - printQueueAttribute :: QueueAttribute -> T.Text - printQueueAttribute QueueAll = "All" -@@ -315,12 +313,12 @@ - printQueueAttribute MessageRetentionPeriod = "MessageRetentionPeriod" - printQueueAttribute QueueArn = "QueueArn" - --parseMessageAttribute :: F.Failure XmlException m => T.Text -> m MessageAttribute -+parseMessageAttribute :: MonadThrow m => T.Text -> m MessageAttribute - parseMessageAttribute "SenderId" = return SenderId - parseMessageAttribute "SentTimestamp" = return SentTimestamp - parseMessageAttribute "ApproximateReceiveCount" = return ApproximateReceiveCount - parseMessageAttribute "ApproximateFirstReceiveTimestamp" = return ApproximateFirstReceiveTimestamp --parseMessageAttribute x = F.failure $ XmlException ( "Invalid Attribute Name. " ++ show x) -+parseMessageAttribute x = throwM $ XmlException ( "Invalid Attribute Name. " ++ show x) - - printMessageAttribute :: MessageAttribute -> T.Text - printMessageAttribute MessageAll = "All" -diff -ru orig/aws.cabal new/aws.cabal ---- orig/aws.cabal 2014-04-04 10:18:25.120401065 +0300 -+++ new/aws.cabal 2014-04-04 10:18:24.000000000 +0300 -@@ -98,8 +98,6 @@ - Aws.DynamoDb.Core - - Build-depends: -- attempt >= 0.3.1.1 && < 0.5, -- attoparsec-conduit >= 1.0 && < 1.1, - aeson >= 0.6 && < 0.8, - base == 4.*, - base16-bytestring == 0.1.*, -@@ -108,29 +106,30 @@ - bytestring >= 0.9 && < 0.11, - case-insensitive >= 0.2 && < 1.3, - cereal >= 0.3 && < 0.5, -- conduit >= 1.0 && < 1.1, -+ conduit >= 1.1 && < 1.2, -+ conduit-extra >= 1.1 && < 1.2, - containers >= 0.4, - crypto-api >= 0.9, - cryptohash >= 0.8 && < 0.12, - cryptohash-cryptoapi == 0.1.*, - data-default == 0.5.*, - directory >= 1.0 && < 1.3, -- failure >= 0.2.0.1 && < 0.3, - filepath >= 1.1 && < 1.4, -- http-conduit >= 1.9 && < 2.1, -+ http-conduit >= 2.1 && < 2.2, - http-types >= 0.7 && < 0.9, - lifted-base >= 0.1 && < 0.3, - monad-control >= 0.3, - mtl == 2.*, - old-locale == 1.*, -- resourcet >= 0.3.3 && <0.5, -+ resourcet >= 1.1 && < 1.2, - text >= 0.11, - time >= 1.1.4 && < 1.5, - transformers >= 0.2.2.0 && < 0.4, - unordered-containers >= 0.2, - utf8-string == 0.3.*, - vector >= 0.10, -- xml-conduit >= 1.1 && <1.2 -+ xml-conduit >= 1.2 && <1.3 -+ , ghc-prim - - GHC-Options: -Wall - diff --git a/patching/patches/aws-0.9.3.patch b/patching/patches/aws-0.9.3.patch new file mode 100644 index 00000000..737b3671 --- /dev/null +++ b/patching/patches/aws-0.9.3.patch @@ -0,0 +1,12 @@ +diff -ruN orig/aws.cabal new/aws.cabal +--- orig/aws.cabal 2014-08-28 07:02:24.655832025 +0300 ++++ new/aws.cabal 2014-08-28 07:02:24.000000000 +0300 +@@ -109,7 +109,7 @@ + bytestring >= 0.9 && < 0.11, + case-insensitive >= 0.2 && < 1.3, + cereal >= 0.3 && < 0.5, +- conduit >= 1.1 && < 1.2, ++ conduit >= 1.1 && < 1.3, + conduit-extra >= 1.1 && < 1.2, + containers >= 0.4, + cryptohash >= 0.11 && < 0.12, diff --git a/patching/patches/bytes-0.14.0.1.patch b/patching/patches/bytes-0.14.0.1.patch deleted file mode 100644 index 8752810a..00000000 --- a/patching/patches/bytes-0.14.0.1.patch +++ /dev/null @@ -1,25 +0,0 @@ -diff -ru orig/src/Data/Bytes/Serial.hs new/src/Data/Bytes/Serial.hs ---- orig/src/Data/Bytes/Serial.hs 2014-06-08 07:58:00.820951939 +0300 -+++ new/src/Data/Bytes/Serial.hs 2014-06-08 07:58:00.000000000 +0300 -@@ -58,7 +58,9 @@ - import Data.Int - import Data.Bits - import Data.Monoid as Monoid -+#if MIN_VERSION_base(4, 6, 0) - import Data.Ord (Down(..)) -+#endif - import Data.Functor.Identity as Functor - import Data.Functor.Constant as Functor - import Data.Functor.Product as Functor -@@ -475,9 +477,11 @@ - serialize = serialize . (fromIntegral::Int -> Int8) . fromEnum - deserialize = (toEnum . (fromIntegral::Int8 -> Int)) `liftM` deserialize - -+#if MIN_VERSION_base(4, 6, 0) - instance Serial a => Serial (Down a) where - serialize (Down a) = serialize a - deserialize = Down `liftM` deserialize -+#endif - - instance Serial Version where - serialize (Version vb ts) = serialize (fmap VarInt vb, ts) diff --git a/patching/patches/bzlib-conduit-0.2.1.1.patch b/patching/patches/bzlib-conduit-0.2.1.1.patch deleted file mode 100644 index b21f3456..00000000 --- a/patching/patches/bzlib-conduit-0.2.1.1.patch +++ /dev/null @@ -1,46 +0,0 @@ -diff -ru orig/bzlib-conduit.cabal new/bzlib-conduit.cabal ---- orig/bzlib-conduit.cabal 2014-04-02 12:25:07.231917434 +0300 -+++ new/bzlib-conduit.cabal 2014-04-02 12:25:06.000000000 +0300 -@@ -26,7 +26,8 @@ - build-depends: base == 4.* - , bytestring >=0.9 && <0.11 - , mtl == 2.* -- , conduit >= 0.5 && < 1.1 -+ , conduit >= 0.5 && < 1.2 -+ , conduit-extra >= 1.0 && < 1.2 - , resourcet - , data-default - , bindings-DSL -@@ -54,7 +55,9 @@ - , QuickCheck - , random - , conduit -+ , conduit-extra - , bzlib-conduit -+ , resourcet - - benchmark bench - type: exitcode-stdio-1.0 -@@ -62,4 +65,5 @@ - main-is: bench.hs - build-depends: base == 4.* - , conduit -+ , conduit-extra - , bzlib-conduit -diff -ru orig/test/test.hs new/test/test.hs ---- orig/test/test.hs 2014-04-02 12:25:07.227917434 +0300 -+++ new/test/test.hs 2014-04-02 12:25:06.000000000 +0300 -@@ -1,6 +1,7 @@ - {-# LANGUAGE ViewPatterns #-} - import Control.Applicative - import Control.Monad -+import Control.Monad.Trans.Resource (runResourceT) - import qualified Data.ByteString.Char8 as S - import qualified Data.ByteString.Lazy.Char8 as L - import Data.Conduit -@@ -36,4 +37,4 @@ - <$> replicateM (abs n) randomIO - dest <- runResourceT $ do - C.sourceList (P.map S.pack ss) =$= bzip2 =$= bunzip2 $$ B.take (10^9) -- return $ dest == L.pack (concat ss) -+ return $ dest == L.pack (P.concat ss) diff --git a/patching/patches/cereal-conduit-0.7.2.patch b/patching/patches/cereal-conduit-0.7.2.patch deleted file mode 100644 index 020ed133..00000000 --- a/patching/patches/cereal-conduit-0.7.2.patch +++ /dev/null @@ -1,53 +0,0 @@ -diff -ru orig/cereal-conduit.cabal new/cereal-conduit.cabal ---- orig/cereal-conduit.cabal 2014-04-03 08:22:14.122388542 +0300 -+++ new/cereal-conduit.cabal 2014-04-03 08:22:13.000000000 +0300 -@@ -19,7 +19,8 @@ - - library - build-depends: base >= 4 && < 5 -- , conduit >= 1.0.0 && < 1.1 -+ , conduit >= 1.0.0 && < 1.2 -+ , resourcet >= 0.4 && < 1.2 - , cereal >= 0.4.0.0 && < 0.5 - , bytestring - , transformers >= 0.2.0.0 -diff -ru orig/Data/Conduit/Cereal.hs new/Data/Conduit/Cereal.hs ---- orig/Data/Conduit/Cereal.hs 2014-04-03 08:22:14.122388542 +0300 -+++ new/Data/Conduit/Cereal.hs 2014-04-03 08:22:13.000000000 +0300 -@@ -19,6 +19,7 @@ - - import Control.Exception.Base - import Control.Monad.Trans.Class (MonadTrans, lift) -+import Control.Monad.Trans.Resource (MonadThrow, monadThrow) - import qualified Data.ByteString as BS - import qualified Data.ByteString.Lazy as LBS - import qualified Data.Conduit as C -@@ -34,7 +35,7 @@ - instance Exception GetException - - -- | Run a 'Get' repeatedly on the input stream, producing an output stream of whatever the 'Get' outputs. --conduitGet :: C.MonadThrow m => Get o -> C.Conduit BS.ByteString m o -+conduitGet :: MonadThrow m => Get o -> C.Conduit BS.ByteString m o - conduitGet = mkConduitGet errorHandler - where errorHandler msg = pipeError $ GetException msg - -@@ -42,7 +43,7 @@ - -- - -- If 'Get' succeed it will return the data read and unconsumed part of the input stream. - -- If the 'Get' fails due to deserialization error or early termination of the input stream it raise an error. --sinkGet :: C.MonadThrow m => Get r -> C.Consumer BS.ByteString m r -+sinkGet :: MonadThrow m => Get r -> C.Consumer BS.ByteString m r - sinkGet = mkSinkGet errorHandler terminationHandler - where errorHandler msg = pipeError $ GetException msg - terminationHandler f = case f BS.empty of -@@ -50,8 +51,8 @@ - Done r lo -> C.leftover lo >> return r - Partial _ -> pipeError $ GetException "Failed reading: Internal error: unexpected Partial." - --pipeError :: (C.MonadThrow m, MonadTrans t, Exception e) => e -> t m a --pipeError e = lift $ C.monadThrow e -+pipeError :: (MonadThrow m, MonadTrans t, Exception e) => e -> t m a -+pipeError e = lift $ monadThrow e - - -- | Convert a 'Put' into a 'Source'. Runs in constant memory. - sourcePut :: Monad m => Put -> C.Producer m BS.ByteString diff --git a/patching/patches/concurrent-extra-0.7.0.6.patch b/patching/patches/concurrent-extra-0.7.0.6.patch deleted file mode 100644 index a217d764..00000000 --- a/patching/patches/concurrent-extra-0.7.0.6.patch +++ /dev/null @@ -1,21 +0,0 @@ -diff -ru orig/concurrent-extra.cabal new/concurrent-extra.cabal ---- orig/concurrent-extra.cabal 2014-04-04 14:42:42.732063525 +0300 -+++ new/concurrent-extra.cabal 2014-04-04 14:42:42.000000000 +0300 -@@ -50,7 +50,7 @@ - ------------------------------------------------------------------------------- - - library -- build-depends: base >= 3 && < 4.7 -+ build-depends: base >= 3 && < 4.8 - , base-unicode-symbols >= 0.1.1 && < 0.3 - , stm >= 2.1.2.1 && < 2.5 - , unbounded-delays >= 0.1 && < 0.2 -@@ -80,7 +80,7 @@ - - ghc-options: -Wall -threaded - -- build-depends: base >= 3 && < 4.7 -+ build-depends: base >= 3 && < 4.8 - , base-unicode-symbols >= 0.1.1 && < 0.3 - , stm >= 2.1.2.1 && < 2.5 - , unbounded-delays >= 0.1 && < 0.2 diff --git a/patching/patches/criterion-1.0.0.2.patch b/patching/patches/criterion-1.0.0.2.patch deleted file mode 100644 index 537611a3..00000000 --- a/patching/patches/criterion-1.0.0.2.patch +++ /dev/null @@ -1,1643 +0,0 @@ -diff -ruN orig/criterion.cabal new/criterion.cabal ---- orig/criterion.cabal 2014-08-10 20:30:05.797809138 +0300 -+++ new/criterion.cabal 2014-08-10 20:30:05.000000000 +0300 -@@ -131,6 +131,7 @@ - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: Tests.hs -+ other-modules: Properties - - ghc-options: - -Wall -threaded -O0 -rtsopts -diff -ruN orig/examples/fibber.html new/examples/fibber.html ---- orig/examples/fibber.html 2014-08-10 20:30:05.789809138 +0300 -+++ new/examples/fibber.html 1970-01-01 02:00:00.000000000 +0200 -@@ -1,726 +0,0 @@ -- -- -- -- -- criterion report -- -- -- -- -- -- -- --
--
--

criterion performance measurements

-- --

overview

-- --

want to understand this report?

-- --
-- --

fib/1

-- -- -- -- -- -- -- -- --
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
lower boundestimateupper bound
OLS regressionxxxxxxxxx
R² goodness-of-fitxxxxxxxxx
Mean execution time2.31459993168433e-82.374225969306158e-82.4336041431094957e-8
Standard deviation1.7147402747620926e-91.984234308811127e-92.3435359738948246e-9
-- -- --

Outlying measurements have severe -- (0.8827515417826841%) -- effect on estimated standard deviation.

-- --

fib/5

-- -- -- -- -- -- -- -- --
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
lower boundestimateupper bound
OLS regressionxxxxxxxxx
R² goodness-of-fitxxxxxxxxx
Mean execution time3.640686812141915e-73.7647973827317373e-73.8862828356384757e-7
Standard deviation3.5904833037515274e-84.150785932735141e-84.81505001531474e-8
-- -- --

Outlying measurements have severe -- (0.917699613099007%) -- effect on estimated standard deviation.

-- --

fib/9

-- -- -- -- -- -- -- -- --
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
lower boundestimateupper bound
OLS regressionxxxxxxxxx
R² goodness-of-fitxxxxxxxxx
Mean execution time2.5489390737084626e-62.614524699113428e-62.700766045605913e-6
Standard deviation2.0893167057513842e-72.4922772413717383e-73.0480780278156827e-7
-- -- --

Outlying measurements have severe -- (0.86814310186276%) -- effect on estimated standard deviation.

-- --

fib/11

-- -- -- -- -- -- -- -- --
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
lower boundestimateupper bound
OLS regressionxxxxxxxxx
R² goodness-of-fitxxxxxxxxx
Mean execution time6.347714383730146e-66.496202868182492e-66.668634037917654e-6
Standard deviation4.0420784296930194e-74.919233380857326e-76.202125623223447e-7
-- -- --

Outlying measurements have severe -- (0.7876656352417168%) -- effect on estimated standard deviation.

-- -- --

understanding this report

-- --

In this report, each function benchmarked by criterion is assigned -- a section of its own. The charts in each section are active; if -- you hover your mouse over data points and annotations, you will see -- more details.

-- --
    --
  • The chart on the left is a -- kernel -- density estimate (also known as a KDE) of time -- measurements. This graphs the probability of any given time -- measurement occurring. A spike indicates that a measurement of a -- particular time occurred; its height indicates how often that -- measurement was repeated.
    • -- --
  • The chart on the right is the raw data from which the kernel -- density estimate is built. The x axis indicates the -- number of loop iterations, while the y axis shows measured -- execution time for the given number of loop iterations. The -- line behind the values is the linear regression prediction of -- execution time for a given number of iterations. Ideally, all -- measurements will be on (or very near) this line.
    • --
-- --

Under the charts is a small table. -- The first two rows are the results of a linear regression run -- on the measurements displayed in the right-hand chart.

-- --
    --
  • OLS regression indicates the -- time estimated for a single loop iteration using an ordinary -- least-squares regression model. This number is more accurate -- than the mean estimate below it, as it more effectively -- eliminates measurement overhead and other constant factors.
    • --
  • R² goodness-of-fit is a measure of how -- accurately the linear regression model fits the observed -- measurements. If the measurements are not too noisy, R² -- should lie between 0.99 and 1, indicating an excellent fit. If -- the number is below 0.99, something is confounding the accuracy -- of the linear model.
    • --
  • Mean execution time and standard deviation are -- statistics calculated from execution time -- divided by number of iterations.
    • --
-- --

We use a statistical technique called -- the bootstrap -- to provide confidence intervals on our estimates. The -- bootstrap-derived upper and lower bounds on estimates let you see -- how accurate we believe those estimates to be. (Hover the mouse -- over the table headers to see the confidence levels.)

-- --

A noisy benchmarking environment can cause some or many -- measurements to fall far from the mean. These outlying -- measurements can have a significant inflationary effect on the -- estimate of the standard deviation. We calculate and display an -- estimate of the extent to which the standard deviation has been -- inflated by outliers.

-- -- -- --
--
-- -- -- -diff -ruN orig/examples/maps.html new/examples/maps.html ---- orig/examples/maps.html 2014-08-10 20:30:05.789809138 +0300 -+++ new/examples/maps.html 1970-01-01 02:00:00.000000000 +0200 -@@ -1,552 +0,0 @@ -- -- -- -- -- criterion report -- -- -- -- -- -- -- --
--
--

criterion performance measurements

-- --

overview

-- --

want to understand this report?

-- --
-- --

ByteString/HashMap/random

-- -- -- -- -- -- -- -- --
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
lower boundestimateupper bound
OLS regressionxxxxxxxxx
R² goodness-of-fitxxxxxxxxx
Mean execution time5.54613319607341e-35.621667703915931e-35.713526073454561e-3
Standard deviation1.972562820146363e-42.494938876886024e-43.1487131555210624e-4
-- -- --

Outlying measurements have moderate -- (0.21993690418913867%) -- effect on estimated standard deviation.

-- -- --

understanding this report

-- --

In this report, each function benchmarked by criterion is assigned -- a section of its own. The charts in each section are active; if -- you hover your mouse over data points and annotations, you will see -- more details.

-- --
    --
  • The chart on the left is a -- kernel -- density estimate (also known as a KDE) of time -- measurements. This graphs the probability of any given time -- measurement occurring. A spike indicates that a measurement of a -- particular time occurred; its height indicates how often that -- measurement was repeated.
    • -- --
  • The chart on the right is the raw data from which the kernel -- density estimate is built. The x axis indicates the -- number of loop iterations, while the y axis shows measured -- execution time for the given number of loop iterations. The -- line behind the values is the linear regression prediction of -- execution time for a given number of iterations. Ideally, all -- measurements will be on (or very near) this line.
    • --
-- --

Under the charts is a small table. -- The first two rows are the results of a linear regression run -- on the measurements displayed in the right-hand chart.

-- --
    --
  • OLS regression indicates the -- time estimated for a single loop iteration using an ordinary -- least-squares regression model. This number is more accurate -- than the mean estimate below it, as it more effectively -- eliminates measurement overhead and other constant factors.
    • --
  • R² goodness-of-fit is a measure of how -- accurately the linear regression model fits the observed -- measurements. If the measurements are not too noisy, R² -- should lie between 0.99 and 1, indicating an excellent fit. If -- the number is below 0.99, something is confounding the accuracy -- of the linear model.
    • --
  • Mean execution time and standard deviation are -- statistics calculated from execution time -- divided by number of iterations.
    • --
-- --

We use a statistical technique called -- the bootstrap -- to provide confidence intervals on our estimates. The -- bootstrap-derived upper and lower bounds on estimates let you see -- how accurate we believe those estimates to be. (Hover the mouse -- over the table headers to see the confidence levels.)

-- --

A noisy benchmarking environment can cause some or many -- measurements to fall far from the mean. These outlying -- measurements can have a significant inflationary effect on the -- estimate of the standard deviation. We calculate and display an -- estimate of the extent to which the standard deviation has been -- inflated by outliers.

-- -- -- --
--
-- -- -- -diff -ruN orig/templates/default2.tpl new/templates/default2.tpl ---- orig/templates/default2.tpl 2014-08-10 20:30:05.793809138 +0300 -+++ new/templates/default2.tpl 1970-01-01 02:00:00.000000000 +0200 -@@ -1,296 +0,0 @@ -- -- -- -- -- criterion report -- -- -- -- -- -- -- -- --
--
--

criterion performance measurements

-- --

overview

-- --

want to understand this report?

-- --
-- --{{#report}} --

{{name}}

-- -- -- -- -- -- -- -- --
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
lower boundestimateupper bound
Mean execution time{{anMean.estLowerBound}}{{anMean.estPoint}}{{anMean.estUpperBound}}
Standard deviation{{anStdDev.estLowerBound}}{{anStdDev.estPoint}}{{anStdDev.estUpperBound}}
-- -- --

Outlying measurements have {{anOutlierVar.ovDesc}} -- ({{anOutlierVar.ovFraction}}%) -- effect on estimated standard deviation.

-- --{{/report}} -- --

understanding this report

-- --

In this report, each function benchmarked by criterion is assigned -- a section of its own. In each section, we display two charts, each -- with an x axis that represents measured execution time. -- These charts are active; if you hover your mouse over data points -- and annotations, you will see more details.

-- --
    --
  • The chart on the left is a -- kernel -- density estimate (also known as a KDE) of time -- measurements. This graphs the probability of any given time -- measurement occurring. A spike indicates that a measurement of a -- particular time occurred; its height indicates how often that -- measurement was repeated.
    • -- --
  • The chart on the right is the raw data from which the kernel -- density estimate is built. Measurements are displayed on -- the x axis in the order in which they occurred. The -- number of iterations of the measurement loop increases with each -- successive measurement.
    • --
-- --

Under the charts is a small table displaying the mean and standard -- deviation of the measurements. We use a statistical technique -- called -- the bootstrap -- to provide confidence intervals on our estimates of these values. -- The bootstrap-derived upper and lower bounds on the mean and -- standard deviation let you see how accurate we believe those -- estimates to be. (Hover the mouse over the table headers to see -- the confidence levels.)

-- --

A noisy benchmarking environment can cause some or many -- measurements to fall far from the mean. These outlying -- measurements can have a significant inflationary effect on the -- estimate of the standard deviation. We calculate and display an -- estimate of the extent to which the standard deviation has been -- inflated by outliers.

-- -- -- --
--
-- -- -- -diff -ruN orig/tests/Properties.hs new/tests/Properties.hs ---- orig/tests/Properties.hs 1970-01-01 02:00:00.000000000 +0200 -+++ new/tests/Properties.hs 2014-08-10 20:30:05.000000000 +0300 -@@ -0,0 +1,42 @@ -+{-# LANGUAGE CPP #-} -+{-# OPTIONS_GHC -fno-warn-orphans #-} -+ -+module Properties (tests) where -+ -+import Control.Applicative ((<$>)) -+import Criterion.Analysis -+import Statistics.Types (Sample) -+import Test.Framework (Test, testGroup) -+import Test.Framework.Providers.QuickCheck2 (testProperty) -+import Test.QuickCheck -+import qualified Data.Vector.Generic as G -+import qualified Data.Vector.Unboxed as U -+ -+#if __GLASGOW_HASKELL__ >= 704 -+import Data.Monoid ((<>)) -+#else -+import Data.Monoid -+ -+(<>) :: Monoid m => m -> m -> m -+(<>) = mappend -+infixr 6 <> -+#endif -+ -+instance (Arbitrary a, U.Unbox a) => Arbitrary (U.Vector a) where -+ arbitrary = U.fromList <$> arbitrary -+ shrink = map U.fromList . shrink . U.toList -+ -+outlier_bucketing :: Double -> Sample -> Bool -+outlier_bucketing y ys = -+ countOutliers (classifyOutliers xs) <= fromIntegral (G.length xs) -+ where xs = U.cons y ys -+ -+outlier_bucketing_weighted :: Double -> Sample -> Bool -+outlier_bucketing_weighted x xs = -+ outlier_bucketing x (xs <> G.replicate (G.length xs * 10) 0) -+ -+tests :: Test -+tests = testGroup "Properties" [ -+ testProperty "outlier_bucketing" outlier_bucketing -+ , testProperty "outlier_bucketing_weighted" outlier_bucketing_weighted -+ ] diff --git a/patching/patches/csv-conduit-0.6.2.1.patch b/patching/patches/csv-conduit-0.6.2.1.patch deleted file mode 100644 index 65af565b..00000000 --- a/patching/patches/csv-conduit-0.6.2.1.patch +++ /dev/null @@ -1,32 +0,0 @@ -diff -ru orig/csv-conduit.cabal new/csv-conduit.cabal ---- orig/csv-conduit.cabal 2014-04-03 10:44:52.994206357 +0300 -+++ new/csv-conduit.cabal 2014-04-03 10:44:52.000000000 +0300 -@@ -78,6 +78,7 @@ - , base >= 4 && < 5 - , bytestring - , conduit >= 1.0 && < 2.0 -+ , conduit-extra - , containers >= 0.3 - , monad-control - , text -@@ -90,6 +91,7 @@ - , mtl - , mmorph - , primitive -+ , resourcet - ghc-prof-options: -fprof-auto - - if impl(ghc >= 7.2.1) -diff -ru orig/src/Data/CSV/Conduit.hs new/src/Data/CSV/Conduit.hs ---- orig/src/Data/CSV/Conduit.hs 2014-04-03 10:44:52.962206360 +0300 -+++ new/src/Data/CSV/Conduit.hs 2014-04-03 10:44:52.000000000 +0300 -@@ -36,6 +36,9 @@ - import Control.Monad.Primitive - import Control.Monad.ST - import Control.Monad.Trans -+import Control.Monad.Trans.Resource (MonadResource, MonadThrow, -+ runExceptionT, -+ runResourceT) - import Data.Attoparsec.Types (Parser) - import qualified Data.ByteString as B - import Data.ByteString.Char8 (ByteString) diff --git a/patching/patches/diagrams-builder-0.5.0.10.patch b/patching/patches/diagrams-builder-0.5.0.10.patch deleted file mode 100644 index 0cb5e37f..00000000 --- a/patching/patches/diagrams-builder-0.5.0.10.patch +++ /dev/null @@ -1,12 +0,0 @@ -diff -ru orig/diagrams-builder.cabal new/diagrams-builder.cabal ---- orig/diagrams-builder.cabal 2014-05-23 06:40:50.633726383 +0300 -+++ new/diagrams-builder.cabal 2014-05-23 06:40:50.000000000 +0300 -@@ -59,7 +59,7 @@ - cmdargs >= 0.6 && < 0.11, - lens >= 3.9 && < 4.2, - hashable >= 1.1 && < 1.3, -- exceptions >= 0.3 && < 0.6 -+ exceptions >= 0.3 && < 0.7 - hs-source-dirs: src - default-language: Haskell2010 - other-extensions: StandaloneDeriving, diff --git a/patching/patches/diagrams-builder-0.5.0.6.patch b/patching/patches/diagrams-builder-0.5.0.6.patch deleted file mode 100644 index c29a564d..00000000 --- a/patching/patches/diagrams-builder-0.5.0.6.patch +++ /dev/null @@ -1,12 +0,0 @@ -diff -ru orig/diagrams-builder.cabal new/diagrams-builder.cabal ---- orig/diagrams-builder.cabal 2014-04-03 08:17:21.630394766 +0300 -+++ new/diagrams-builder.cabal 2014-04-03 08:17:21.000000000 +0300 -@@ -59,7 +59,7 @@ - cmdargs >= 0.6 && < 0.11, - lens >= 3.9 && < 4.2, - hashable >= 1.1 && < 1.3, -- exceptions >= 0.3 && < 0.4 -+ exceptions >= 0.3 && < 0.6 - hs-source-dirs: src - default-language: Haskell2010 - other-extensions: StandaloneDeriving, diff --git a/patching/patches/diagrams-builder-0.5.0.9.patch b/patching/patches/diagrams-builder-0.5.0.9.patch deleted file mode 100644 index 76d35ebd..00000000 --- a/patching/patches/diagrams-builder-0.5.0.9.patch +++ /dev/null @@ -1,12 +0,0 @@ -diff -ru orig/diagrams-builder.cabal new/diagrams-builder.cabal ---- orig/diagrams-builder.cabal 2014-05-11 11:28:24.019992070 +0300 -+++ new/diagrams-builder.cabal 2014-05-11 11:28:23.000000000 +0300 -@@ -59,7 +59,7 @@ - cmdargs >= 0.6 && < 0.11, - lens >= 3.9 && < 4.2, - hashable >= 1.1 && < 1.3, -- exceptions >= 0.3 && < 0.6 -+ exceptions >= 0.3 && < 0.7 - hs-source-dirs: src - default-language: Haskell2010 - other-extensions: StandaloneDeriving, diff --git a/patching/patches/diagrams-builder-0.6.patch b/patching/patches/diagrams-builder-0.6.patch deleted file mode 100644 index 82a40d0e..00000000 --- a/patching/patches/diagrams-builder-0.6.patch +++ /dev/null @@ -1,27 +0,0 @@ -diff -ruN orig/diagrams-builder.cabal new/diagrams-builder.cabal ---- orig/diagrams-builder.cabal 2014-08-10 08:43:22.462711726 +0300 -+++ new/diagrams-builder.cabal 2014-08-10 08:43:22.000000000 +0300 -@@ -57,7 +57,7 @@ - split >= 0.2 && < 0.3, - haskell-src-exts >= 1.14 && < 1.16, - cmdargs >= 0.6 && < 0.11, -- lens >= 3.9 && < 4.3, -+ lens, - hashable >= 1.1 && < 1.3, - exceptions >= 0.3 && < 0.7 - hs-source-dirs: src -@@ -100,7 +100,7 @@ - diagrams-lib >= 0.6 && < 1.3, - diagrams-cairo >= 0.6 && < 1.3, - cmdargs >= 0.6 && < 0.11, -- lens >= 3.8 && < 4.3 -+ lens - - executable diagrams-builder-svg - main-is: diagrams-builder-svg.hs -@@ -141,4 +141,4 @@ - diagrams-lib >= 0.6 && < 1.3, - diagrams-postscript >= 0.6 && < 1.2, - cmdargs >= 0.6 && < 0.11, -- lens >= 3.8 && < 4.3 -+ lens diff --git a/patching/patches/diagrams-haddock-0.2.2.10.patch b/patching/patches/diagrams-haddock-0.2.2.10.patch deleted file mode 100644 index 0fd00354..00000000 --- a/patching/patches/diagrams-haddock-0.2.2.10.patch +++ /dev/null @@ -1,21 +0,0 @@ -diff -ruN orig/diagrams-haddock.cabal new/diagrams-haddock.cabal ---- orig/diagrams-haddock.cabal 2014-08-10 08:43:22.698711721 +0300 -+++ new/diagrams-haddock.cabal 2014-08-10 08:43:22.000000000 +0300 -@@ -48,7 +48,7 @@ - diagrams-lib >= 0.6 && < 1.3, - diagrams-svg >= 0.8.0.1 && < 1.2, - vector-space >= 0.8 && < 0.9, -- lens >= 3.8 && < 4.3, -+ lens, - cpphs >= 1.15, - cautious-file >= 1.0 && < 1.1, - uniplate >= 1.6 && < 1.7, -@@ -81,7 +81,7 @@ - tasty-quickcheck >= 0.8 && < 0.9, - parsec >= 3, - haskell-src-exts >= 1.14 && < 1.16, -- lens >= 3.8 && < 4.3, -+ lens, - diagrams-haddock - hs-source-dirs: test - default-language: Haskell2010 diff --git a/patching/patches/distributed-process-0.4.2.patch b/patching/patches/distributed-process-0.4.2.patch deleted file mode 100644 index fc328128..00000000 --- a/patching/patches/distributed-process-0.4.2.patch +++ /dev/null @@ -1,96 +0,0 @@ -diff -ru orig/distributed-process.cabal new/distributed-process.cabal ---- orig/distributed-process.cabal 2014-03-27 18:23:44.792359466 +0200 -+++ new/distributed-process.cabal 2014-03-27 18:23:44.000000000 +0200 -@@ -39,7 +39,7 @@ - - Library - Build-Depends: base >= 4.4 && < 5, -- binary >= 0.5 && < 0.7, -+ binary >= 0.5, - network-transport >= 0.3 && < 0.4, - stm >= 2.3 && < 2.5, - transformers >= 0.2 && < 0.4, -@@ -53,7 +53,7 @@ - ghc-prim >= 0.2 && < 0.4, - distributed-static >= 0.2 && < 0.3, - rank1dynamic >= 0.1 && < 0.2, -- syb >= 0.3 && < 0.4 -+ syb >= 0.3 - Exposed-modules: Control.Distributed.Process, - Control.Distributed.Process.Serializable, - Control.Distributed.Process.Closure, -@@ -90,11 +90,11 @@ - Main-Is: TestCH.hs - Build-Depends: base >= 4.4 && < 5, - random >= 1.0 && < 1.1, -- ansi-terminal >= 0.5 && < 0.6, -+ ansi-terminal >= 0.5, - distributed-process, - network-transport >= 0.3 && < 0.4, - network-transport-tcp >= 0.3 && < 0.4, -- binary >= 0.5 && < 0.7, -+ binary >= 0.5, - network >= 2.3 && < 2.5, - HUnit >= 1.2 && < 1.3, - test-framework >= 0.6 && < 0.9, -@@ -111,7 +111,7 @@ - Main-Is: TestClosure.hs - Build-Depends: base >= 4.4 && < 5, - random >= 1.0 && < 1.1, -- ansi-terminal >= 0.5 && < 0.6, -+ ansi-terminal >= 0.5, - distributed-static >= 0.2 && < 0.3, - distributed-process, - network-transport >= 0.3 && < 0.4, -@@ -131,13 +131,13 @@ - Main-Is: TestStats.hs - Build-Depends: base >= 4.4 && < 5, - random >= 1.0 && < 1.1, -- ansi-terminal >= 0.5 && < 0.6, -+ ansi-terminal >= 0.5, - containers >= 0.4 && < 0.6, - stm >= 2.3 && < 2.5, - distributed-process, - network-transport >= 0.3 && < 0.4, - network-transport-tcp >= 0.3 && < 0.4, -- binary >= 0.5 && < 0.7, -+ binary >= 0.5, - network >= 2.3 && < 2.5, - HUnit >= 1.2 && < 1.3, - test-framework >= 0.6 && < 0.9, -@@ -156,7 +156,7 @@ - distributed-process, - network-transport-tcp >= 0.3 && < 0.4, - bytestring >= 0.9 && < 0.11, -- binary >= 0.5 && < 0.7 -+ binary >= 0.5 - else - buildable: False - Main-Is: benchmarks/Throughput.hs -@@ -169,7 +169,7 @@ - distributed-process, - network-transport-tcp >= 0.3 && < 0.4, - bytestring >= 0.9 && < 0.11, -- binary >= 0.5 && < 0.7 -+ binary >= 0.5 - else - buildable: False - Main-Is: benchmarks/Latency.hs -@@ -182,7 +182,7 @@ - distributed-process, - network-transport-tcp >= 0.3 && < 0.4, - bytestring >= 0.9 && < 0.11, -- binary >= 0.5 && < 0.7 -+ binary >= 0.5 - else - buildable: False - Main-Is: benchmarks/Channels.hs -@@ -195,7 +195,7 @@ - distributed-process, - network-transport-tcp >= 0.3 && < 0.4, - bytestring >= 0.9 && < 0.11, -- binary >= 0.5 && < 0.7 -+ binary >= 0.5 - else - buildable: False - Main-Is: benchmarks/Spawns.hs diff --git a/patching/patches/distributed-process-simplelocalnet-0.2.0.9.patch b/patching/patches/distributed-process-simplelocalnet-0.2.0.9.patch deleted file mode 100644 index 643c125c..00000000 --- a/patching/patches/distributed-process-simplelocalnet-0.2.0.9.patch +++ /dev/null @@ -1,21 +0,0 @@ -diff -ru orig/distributed-process-simplelocalnet.cabal new/distributed-process-simplelocalnet.cabal ---- orig/distributed-process-simplelocalnet.cabal 2014-03-27 18:23:44.960359467 +0200 -+++ new/distributed-process-simplelocalnet.cabal 2014-03-27 18:23:44.000000000 +0200 -@@ -33,7 +33,7 @@ - network >= 2.3 && < 2.5, - network-multicast >= 0.0 && < 0.1, - data-accessor >= 0.2 && < 0.3, -- binary >= 0.5 && < 0.7, -+ binary >= 0.5, - containers >= 0.4 && < 0.6, - transformers >= 0.2 && < 0.4, - network-transport >= 0.3 && < 0.4, -@@ -55,7 +55,7 @@ - network >= 2.3 && < 2.5, - network-multicast >= 0.0 && < 0.1, - data-accessor >= 0.2 && < 0.3, -- binary >= 0.5 && < 0.7, -+ binary >= 0.5, - containers >= 0.4 && < 0.6, - transformers >= 0.2 && < 0.4, - network-transport >= 0.3 && < 0.4, diff --git a/patching/patches/distributive-0.4.3.patch b/patching/patches/distributive-0.4.3.patch deleted file mode 100644 index 33b0d8b4..00000000 --- a/patching/patches/distributive-0.4.3.patch +++ /dev/null @@ -1,11 +0,0 @@ -diff -ru orig/distributive.cabal new/distributive.cabal ---- orig/distributive.cabal 2014-04-03 09:44:06.518283977 +0300 -+++ new/distributive.cabal 2014-04-03 09:44:06.000000000 +0300 -@@ -36,6 +36,7 @@ - tagged >= 0.7 && < 1, - transformers >= 0.2 && < 0.4, - transformers-compat >= 0.1 && < 0.2 -+ , ghc-prim - - hs-source-dirs: src - exposed-modules: diff --git a/patching/patches/esqueleto-1.3.8.patch b/patching/patches/esqueleto-1.3.8.patch deleted file mode 100644 index 0a3c3c1d..00000000 --- a/patching/patches/esqueleto-1.3.8.patch +++ /dev/null @@ -1,12 +0,0 @@ -diff -ru orig/esqueleto.cabal new/esqueleto.cabal ---- orig/esqueleto.cabal 2014-04-03 08:31:02.238377300 +0300 -+++ new/esqueleto.cabal 2014-04-03 08:31:01.000000000 +0300 -@@ -91,7 +91,7 @@ - , containers - , HUnit - , QuickCheck -- , hspec >= 1.9 -+ , hspec >= 1.8 - , persistent-sqlite >= 1.2 && < 1.4 - , persistent-template >= 1.2 && < 1.4 - , monad-control diff --git a/patching/patches/fay-0.19.0.2.patch b/patching/patches/fay-0.19.0.2.patch deleted file mode 100644 index 1c5f81ac..00000000 --- a/patching/patches/fay-0.19.0.2.patch +++ /dev/null @@ -1,12 +0,0 @@ -diff -ru orig/fay.cabal new/fay.cabal ---- orig/fay.cabal 2014-03-13 05:59:43.874058759 +0200 -+++ new/fay.cabal 2014-03-13 05:59:43.000000000 +0200 -@@ -122,7 +122,7 @@ - , language-ecmascript >= 0.15 && < 1.0 - , mtl < 2.2 - , pretty-show >= 1.6 && < 1.7 -- , process < 1.2 -+ , process < 1.3 - , safe < 0.4 - , split < 0.3 - , syb < 0.5 diff --git a/patching/patches/fb-1.0.1.patch b/patching/patches/fb-1.0.1.patch deleted file mode 100644 index 0f7d0078..00000000 --- a/patching/patches/fb-1.0.1.patch +++ /dev/null @@ -1,12 +0,0 @@ -diff -ru orig/fb.cabal new/fb.cabal ---- orig/fb.cabal 2014-06-30 12:41:53.267551936 +0300 -+++ new/fb.cabal 2014-06-30 12:41:52.000000000 +0300 -@@ -76,7 +76,7 @@ - , data-default - , http-types - , http-conduit >= 2.0 && < 2.2 -- , attoparsec >= 0.10.4 && < 0.12 -+ , attoparsec >= 0.10.4 && < 0.13 - , unordered-containers - , aeson >= 0.5 && < 0.8 - , base16-bytestring >= 0.1 diff --git a/patching/patches/foldl-1.0.2.patch b/patching/patches/foldl-1.0.2.patch deleted file mode 100644 index bc0f24b5..00000000 --- a/patching/patches/foldl-1.0.2.patch +++ /dev/null @@ -1,12 +0,0 @@ -diff -ru orig/foldl.cabal new/foldl.cabal ---- orig/foldl.cabal 2014-03-13 07:47:41.009928017 +0200 -+++ new/foldl.cabal 2014-03-13 07:47:40.000000000 +0200 -@@ -24,7 +24,7 @@ - base >= 4 && < 5 , - bytestring >= 0.9.2.1 && < 0.11, - primitive < 0.6 , -- text >= 0.11.2.0 && < 1.1 , -+ text >= 0.11.2.0 && < 1.2 , - vector >= 0.7 && < 0.11 - Exposed-Modules: - Control.Foldl, diff --git a/patching/patches/force-layout-0.3.0.5.patch b/patching/patches/force-layout-0.3.0.5.patch deleted file mode 100644 index d5603815..00000000 --- a/patching/patches/force-layout-0.3.0.5.patch +++ /dev/null @@ -1,12 +0,0 @@ -diff -ruN orig/force-layout.cabal new/force-layout.cabal ---- orig/force-layout.cabal 2014-08-10 08:43:22.898711717 +0300 -+++ new/force-layout.cabal 2014-08-10 08:43:22.000000000 +0300 -@@ -23,7 +23,7 @@ - build-depends: base >= 4.2 && < 4.8, - vector-space >=0.7 && <0.9, - vector-space-points >= 0.1.1 && < 0.3, -- lens >= 3 && < 4.3, -+ lens, - containers >=0.4 && < 0.6, - data-default-class >= 0.0.1 && < 0.1 - hs-source-dirs: src diff --git a/patching/patches/github-0.7.4.patch b/patching/patches/github-0.7.4.patch deleted file mode 100644 index 64257902..00000000 --- a/patching/patches/github-0.7.4.patch +++ /dev/null @@ -1,23 +0,0 @@ -diff -ru orig/Github/Private.hs new/Github/Private.hs ---- orig/Github/Private.hs 2014-04-03 09:50:34.182275724 +0300 -+++ new/Github/Private.hs 2014-04-03 09:50:33.000000000 +0300 -@@ -14,7 +14,7 @@ - import qualified Data.ByteString.Lazy.Char8 as LBS - import Network.HTTP.Types (Method, Status(..)) - import Network.HTTP.Conduit --import Data.Conduit (ResourceT) -+import Control.Monad.Trans.Resource (ResourceT) - import qualified Control.Exception as E - import Data.Maybe (fromMaybe) - -diff -ru orig/github.cabal new/github.cabal ---- orig/github.cabal 2014-04-03 09:50:34.194275724 +0300 -+++ new/github.cabal 2014-04-03 09:50:33.000000000 +0300 -@@ -158,6 +158,7 @@ - http-types, - data-default, - vector, -+ resourcet, - unordered-containers >= 0.2 && < 0.3 - - -- Modules not exported by this package. diff --git a/patching/patches/gitlib-3.0.2.patch b/patching/patches/gitlib-3.0.2.patch deleted file mode 100644 index 1e6f8f71..00000000 --- a/patching/patches/gitlib-3.0.2.patch +++ /dev/null @@ -1,191 +0,0 @@ -diff -ru orig/Git/Commit/Push.hs new/Git/Commit/Push.hs ---- orig/Git/Commit/Push.hs 2014-04-06 09:02:45.571789820 +0300 -+++ new/Git/Commit/Push.hs 2014-04-06 09:02:45.000000000 +0300 -@@ -1,11 +1,11 @@ - module Git.Commit.Push where - - import Control.Applicative --import Control.Failure - import Control.Monad - import Control.Monad.IO.Class - import Control.Monad.Trans.Class - import Control.Monad.Trans.Control -+import Control.Monad.Trans.Resource - import Data.Function - import qualified Data.HashSet as HashSet - import Data.List -@@ -33,14 +33,14 @@ - mrref' <- for mrref $ \rref -> - if rref `elem` commits - then lift $ copyCommitOid rref -- else failure $ PushNotFastForward -+ else throwM $ PushNotFastForward - $ "SHA " <> renderObjOid rref - <> " not found in remote" - objs <- lift $ listAllObjects mrref' coid - let shas = HashSet.fromList $ map (renderOid . untagObjOid) objs - (cref,_) <- copyCommit coid Nothing shas - unless (renderObjOid coid == renderObjOid cref) $ -- failure $ BackendError $ "Error copying commit: " -+ throwM $ BackendError $ "Error copying commit: " - <> renderObjOid coid <> " /= " <> renderObjOid cref - -- jww (2013-04-18): This is something the user must decide to do - -- updateReference_ remoteRefName (RefObj cref) -@@ -79,6 +79,6 @@ - - mref <- fmap renderOid <$> resolveReference refName - unless (maybe False (renderObjOid coid ==) mref) $ -- failure (BackendError $ -+ throwM (BackendError $ - "Could not resolve destination reference '" - <> refName <> "'in project") -diff -ru orig/Git/Commit.hs new/Git/Commit.hs ---- orig/Git/Commit.hs 2014-04-06 09:02:45.571789820 +0300 -+++ new/Git/Commit.hs 2014-04-06 09:02:45.000000000 +0300 -@@ -1,8 +1,8 @@ - module Git.Commit where - --import Control.Failure - import Control.Monad - import Control.Monad.Trans.Class -+import Control.Monad.Trans.Resource - import Data.Conduit - import qualified Data.Conduit.List as CL - import Data.Function -@@ -41,7 +41,7 @@ - (parentRefs,needed') <- foldM copyParent ([],needed) parents - (tr,needed'') <- copyTree (commitTree commit) needed' - unless (renderObjOid (commitTree commit) == renderObjOid tr) $ -- failure $ BackendError $ "Error copying tree: " -+ throwM $ BackendError $ "Error copying tree: " - <> renderObjOid (commitTree commit) - <> " /= " <> renderObjOid tr - -@@ -60,7 +60,7 @@ - copyParent (prefs,needed') cref = do - (cref2,needed'') <- copyCommit cref Nothing needed' - unless (renderObjOid cref == renderObjOid cref2) $ -- failure $ BackendError $ "Error copying commit: " -+ throwM $ BackendError $ "Error copying commit: " - <> renderObjOid cref <> " /= " <> renderObjOid cref2 - let x = cref2 `seq` (cref2:prefs) - return $ x `seq` needed'' `seq` (x,needed'') -diff -ru orig/Git/Repository.hs new/Git/Repository.hs ---- orig/Git/Repository.hs 2014-04-06 09:02:45.571789820 +0300 -+++ new/Git/Repository.hs 2014-04-06 09:02:45.000000000 +0300 -@@ -6,6 +6,7 @@ - import Data.Conduit - import Git.Types - import System.Directory -+import Control.Monad.Trans.Control (MonadBaseControl) - - withNewRepository :: (MonadGit r n, MonadBaseControl IO n, MonadIO m) - => RepositoryFactory n m r -diff -ru orig/Git/Tree/Builder.hs new/Git/Tree/Builder.hs ---- orig/Git/Tree/Builder.hs 2014-04-06 09:02:45.571789820 +0300 -+++ new/Git/Tree/Builder.hs 2014-04-06 09:02:45.000000000 +0300 -@@ -25,12 +25,12 @@ - ) where - - import Control.Applicative --import Control.Failure - import Control.Monad - import Control.Monad.Fix - import Control.Monad.Logger - import Control.Monad.IO.Class - import Control.Monad.Trans.Class -+import Control.Monad.Trans.Resource - import Control.Monad.Trans.State - import qualified Data.ByteString as B - import Data.Char -@@ -143,9 +143,9 @@ - - update bm _ _ (Right Nothing) = return (bm, TreeEntryNotFound) - update _ _ _ (Right (Just BlobEntry {})) = -- failure TreeCannotTraverseBlob -+ throwM TreeCannotTraverseBlob - update _ _ _ (Right (Just CommitEntry {})) = -- failure TreeCannotTraverseCommit -+ throwM TreeCannotTraverseCommit - - update bm name names arg = do - sbm <- case arg of -diff -ru orig/Git/Tree.hs new/Git/Tree.hs ---- orig/Git/Tree.hs 2014-04-06 09:02:45.571789820 +0300 -+++ new/Git/Tree.hs 2014-04-06 09:02:45.000000000 +0300 -@@ -1,8 +1,8 @@ - module Git.Tree where - --import Control.Failure - import Control.Monad - import Control.Monad.Trans.Class -+import Control.Monad.Trans.Resource - import Data.Conduit - import qualified Data.Conduit.List as CL - import Data.HashSet (HashSet) -@@ -22,7 +22,7 @@ - copyTreeEntry (BlobEntry oid kind) needed = do - (b,needed') <- copyBlob oid needed - unless (renderObjOid oid == renderObjOid b) $ -- failure $ BackendError $ "Error copying blob: " -+ throwM $ BackendError $ "Error copying blob: " - <> renderObjOid oid <> " /= " <> renderObjOid b - return (BlobEntry b kind, needed') - copyTreeEntry (CommitEntry oid) needed = do -diff -ru orig/Git/Types.hs new/Git/Types.hs ---- orig/Git/Types.hs 2014-04-06 09:02:45.571789820 +0300 -+++ new/Git/Types.hs 2014-04-06 09:02:45.000000000 +0300 -@@ -2,9 +2,9 @@ - - import Control.Applicative - import qualified Control.Exception.Lifted as Exc --import Control.Failure - import Control.Monad - import Control.Monad.Trans.Class -+import Control.Monad.Trans.Resource - import Data.ByteString (ByteString) - import qualified Data.ByteString.Base16 as B16 - import qualified Data.ByteString.Lazy as BL -@@ -35,7 +35,7 @@ - - -- | 'Repository' is the central point of contact between user code and Git - -- data objects. Every object must belong to some repository. --class (Applicative m, Monad m, Failure GitException m, -+class (Applicative m, Monad m, MonadThrow m, - IsOid (Oid r), Show (Oid r), Eq (Oid r), Ord (Oid r)) - => MonadGit r m | m -> r where - type Oid r :: * -diff -ru orig/Git/Working.hs new/Git/Working.hs ---- orig/Git/Working.hs 2014-04-06 09:02:45.571789820 +0300 -+++ new/Git/Working.hs 2014-04-06 09:02:45.000000000 +0300 -@@ -3,7 +3,6 @@ - module Git.Working where - - import Control.Applicative --import Control.Failure - import Control.Monad.IO.Class - import Control.Monad.Trans.Resource - import Data.Conduit -@@ -39,7 +38,7 @@ - | cloneSubmodules -> cloneSubmodule oid fullPath - | otherwise -> liftIO $ createDirectory fullPath - where -- decodeError path e = failure $ PathEncodingError $ -+ decodeError path e = throwM $ PathEncodingError $ - "Could not decode path " <> T.pack (show path) <> ":" <> T.pack e - - checkoutBlob oid kind fullPath = do -diff -ru orig/gitlib.cabal new/gitlib.cabal ---- orig/gitlib.cabal 2014-04-06 09:02:45.575789820 +0300 -+++ new/gitlib.cabal 2014-04-06 09:02:45.000000000 +0300 -@@ -43,9 +43,9 @@ - , base16-bytestring >= 0.1.1.5 - , bytestring >= 0.9.2.1 - , conduit >= 1.0.0 -+ , conduit-extra >= 1.0.0 - , containers >= 0.4.2.1 - , directory >= 1.1.0.2 -- , failure >= 0.2.0.1 - , filepath >= 1.3.0.0 - , hashable >= 1.1.2.5 - , lifted-base >= 0.2 diff --git a/patching/patches/gitlib-cmdline-3.0.1.patch b/patching/patches/gitlib-cmdline-3.0.1.patch deleted file mode 100644 index 0f23a1a2..00000000 --- a/patching/patches/gitlib-cmdline-3.0.1.patch +++ /dev/null @@ -1,43 +0,0 @@ -diff -ru orig/Git/CmdLine.hs new/Git/CmdLine.hs ---- orig/Git/CmdLine.hs 2014-04-06 18:49:23.851795879 +0300 -+++ new/Git/CmdLine.hs 2014-04-06 18:49:23.000000000 +0300 -@@ -23,8 +23,9 @@ - import Control.Monad.Reader.Class - import Control.Monad.Trans.Class - import Control.Monad.Trans.Reader (ReaderT, runReaderT) -+import Control.Monad.Trans.Resource (MonadThrow (..)) - import qualified Data.ByteString as B --import Data.Conduit hiding (MonadBaseControl) -+import Data.Conduit - import qualified Data.Conduit.List as CL - import Data.Foldable (for_) - import Data.Function -@@ -88,7 +89,7 @@ - -- instance HasCliRepo (env, CliRepo) where - -- getCliRepo = snd - --instance (Applicative m, Failure GitException m, MonadIO m) -+instance (Applicative m, Failure GitException m, MonadIO m, MonadThrow m) - => MonadGit CliRepo (ReaderT CliRepo m) where - type Oid CliRepo = SHA - data Tree CliRepo = CmdLineTree (TreeOid CliRepo) -@@ -127,7 +128,7 @@ - - diffContentsWithTree = error "Not defined cliDiffContentsWithTree" - --type MonadCli m = (Applicative m, Failure GitException m, MonadIO m) -+type MonadCli m = (Applicative m, Failure GitException m, MonadIO m, MonadThrow m) - - mkOid :: MonadCli m => forall o. TL.Text -> ReaderT CliRepo m (Tagged o SHA) - mkOid = fmap Tagged <$> textToSha . toStrict -diff -ru orig/gitlib-cmdline.cabal new/gitlib-cmdline.cabal ---- orig/gitlib-cmdline.cabal 2014-04-06 18:49:23.895795879 +0300 -+++ new/gitlib-cmdline.cabal 2014-04-06 18:49:23.000000000 +0300 -@@ -39,6 +39,7 @@ - , transformers >= 0.2.2 - , transformers-base >= 0.4.1 - , unordered-containers >= 0.2.3.0 -+ , resourcet - exposed-modules: - Git.CmdLine - diff --git a/patching/patches/gitlib-libgit2-3.0.1.patch b/patching/patches/gitlib-libgit2-3.0.1.patch deleted file mode 100644 index 2dc8376a..00000000 --- a/patching/patches/gitlib-libgit2-3.0.1.patch +++ /dev/null @@ -1,280 +0,0 @@ -diff -ru orig/Git/Libgit2/Internal.hs new/Git/Libgit2/Internal.hs ---- orig/Git/Libgit2/Internal.hs 2014-04-06 09:02:46.523789820 +0300 -+++ new/Git/Libgit2/Internal.hs 2014-04-06 09:02:46.000000000 +0300 -@@ -8,9 +8,9 @@ - - import Bindings.Libgit2 - import Control.Applicative --import Control.Failure - import Control.Monad - import Control.Monad.Trans.Control -+import Control.Monad.Trans.Resource - import Data.ByteString - import qualified Data.Text as T - import qualified Data.Text.ICU.Convert as U -@@ -85,7 +85,7 @@ - let p = castPtr ptr' - fptr <- FC.newForeignPtr p (c'git_object_free p) - run $ Right <$> createFn coidCopy (castForeignPtr fptr) ptr' -- either (failure . Git.BackendError) return result -+ either (throwM . Git.BackendError) return result - - -- lgLookupObject :: Text -> LgRepository Dynamic - -- lgLookupObject str -diff -ru orig/Git/Libgit2/Types.hs new/Git/Libgit2/Types.hs ---- orig/Git/Libgit2/Types.hs 2014-04-06 09:02:46.523789820 +0300 -+++ new/Git/Libgit2/Types.hs 2014-04-06 09:02:46.000000000 +0300 -@@ -10,10 +10,10 @@ - - import Bindings.Libgit2 - import Control.Applicative --import Control.Failure - import Control.Monad.IO.Class - import Control.Monad.Logger - import Control.Monad.Trans.Control -+import Control.Monad.Trans.Resource - import Data.IORef - import Foreign.ForeignPtr - import qualified Git -@@ -52,7 +52,7 @@ - type TreeBuilder = Git.TreeBuilder LgRepo - type Options = Git.Options LgRepo - --type MonadLg m = (Applicative m, Failure Git.GitException m, -+type MonadLg m = (Applicative m, MonadThrow m, - MonadIO m, MonadBaseControl IO m, MonadLogger m) - - -- Types.hs -diff -ru orig/Git/Libgit2.hs new/Git/Libgit2.hs ---- orig/Git/Libgit2.hs 2014-04-06 09:02:46.523789820 +0300 -+++ new/Git/Libgit2.hs 2014-04-06 09:02:46.000000000 +0300 -@@ -60,7 +60,6 @@ - import Control.Concurrent.Async.Lifted - import Control.Concurrent.STM - import Control.Exception.Lifted --import Control.Failure - import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence) - import Control.Monad.IO.Class - import Control.Monad.Logger -@@ -154,11 +153,11 @@ - - lgParseOid :: MonadLg m => Text -> m Oid - lgParseOid str -- | len > 40 = failure (Git.OidParseFailed str) -+ | len > 40 = throwM (Git.OidParseFailed str) - | otherwise = do - moid <- liftIO $ lgParseOidIO str len - case moid of -- Nothing -> failure (Git.OidParseFailed str) -+ Nothing -> throwM (Git.OidParseFailed str) - Just oid -> return oid - where - len = T.length str -@@ -179,7 +178,7 @@ - instance Eq OidPtr where - oid1 == oid2 = oid1 `compare` oid2 == EQ - --instance (Applicative m, Failure Git.GitException m, -+instance (Applicative m, MonadThrow m, - MonadBaseControl IO m, MonadIO m, MonadLogger m) - => Git.MonadGit LgRepo (ReaderT LgRepo m) where - type Oid LgRepo = OidPtr -@@ -427,7 +426,7 @@ - return $ Just fptr - case mfptr of - Nothing -> -- failure (Git.TreeCreateFailed "Failed to create new tree builder") -+ throwM (Git.TreeCreateFailed "Failed to create new tree builder") - Just fptr -> do - toid <- mapM Git.treeOid mtree - return (lgMakeBuilder fptr) { Git.mtbBaseTreeOid = toid } -@@ -441,7 +440,7 @@ - withFilePath key $ \name -> - c'git_treebuilder_insert nullPtr ptr name coid - (fromIntegral mode) -- when (r2 < 0) $ failure (Git.TreeBuilderInsertFailed key) -+ when (r2 < 0) $ throwM (Git.TreeBuilderInsertFailed key) - - treeEntryToOid :: TreeEntry -> (Oid, CUInt) - treeEntryToOid (Git.BlobEntry oid kind) = -@@ -503,7 +502,7 @@ - liftIO $ withForeignPtr fptr $ \builder -> alloca $ \pptr -> do - r <- c'git_treebuilder_create pptr nullPtr - when (r < 0) $ -- failure (Git.BackendError "Could not create new treebuilder") -+ throwM (Git.BackendError "Could not create new treebuilder") - builder' <- peek pptr - bracket - (mk'git_treebuilder_filter_cb (callback builder')) -@@ -522,7 +521,7 @@ - coid - fmode - when (r < 0) $ -- failure (Git.BackendError "Could not insert entry in treebuilder") -+ throwM (Git.BackendError "Could not insert entry in treebuilder") - return 0 - - lgLookupTree :: MonadLg m => TreeOid -> ReaderT LgRepo m Tree -@@ -547,7 +546,7 @@ - 0o100644 -> return Git.PlainBlob - 0o100755 -> return Git.ExecutableBlob - 0o120000 -> return Git.SymlinkBlob -- _ -> failure $ Git.BackendError $ -+ _ -> throwM $ Git.BackendError $ - "Unknown blob mode: " <> T.pack (show mode) - | typ == c'GIT_OBJ_TREE -> - return $ Git.TreeEntry (Tagged (mkOid oid)) -@@ -642,7 +641,7 @@ - r1 <- c'git_odb_exists ptr coid 0 - c'git_odb_free ptr - return (Just (r1 == 0)) -- maybe (failure Git.RepositoryInvalid) return result -+ maybe (throwM Git.RepositoryInvalid) return result - - lgForEachObject :: Ptr C'git_odb - -> (Ptr C'git_oid -> Ptr () -> IO CInt) -@@ -663,7 +662,7 @@ - r <- withForeignPtr (repoObj repo) $ \repoPtr -> - c'git_revwalk_new pptr repoPtr - when (r < 0) $ -- failure (Git.BackendError "Could not create revwalker") -+ throwM (Git.BackendError "Could not create revwalker") - ptr <- peek pptr - FC.newForeignPtr ptr (c'git_revwalk_free ptr) - -@@ -673,7 +672,7 @@ - liftIO $ withForeignPtr (getOid oid) $ \coid -> do - r2 <- withForeignPtr walker $ flip c'git_revwalk_push coid - when (r2 < 0) $ -- failure (Git.BackendError $ "Could not push oid " -+ throwM (Git.BackendError $ "Could not push oid " - <> pack (show oid) <> " onto revwalker") - - case mhave of -@@ -681,7 +680,7 @@ - Just have -> liftIO $ withForeignPtr (getOid (untag have)) $ \coid -> do - r2 <- withForeignPtr walker $ flip c'git_revwalk_hide coid - when (r2 < 0) $ -- failure (Git.BackendError $ "Could not hide commit " -+ throwM (Git.BackendError $ "Could not hide commit " - <> pack (show (untag have)) <> " from revwalker") - - liftIO $ withForeignPtr walker $ flip c'git_revwalk_sorting -@@ -831,7 +830,7 @@ - else do - ref <- peek ptr - c'git_reference_delete ref -- when (r < 0) $ failure (Git.ReferenceDeleteFailed name) -+ when (r < 0) $ throwM (Git.ReferenceDeleteFailed name) - - -- int git_reference_packall(git_repository *repo) - -@@ -957,7 +956,7 @@ - - --compareRef = c'git_reference_cmp - --lgThrow :: (MonadIO m, Failure e m) => (Text -> e) -> m () -+lgThrow :: (Exception e, MonadIO m, MonadThrow m) => (Text -> e) -> m () - lgThrow f = do - errStr <- liftIO $ do - errPtr <- c'giterr_last -@@ -966,7 +965,7 @@ - else do - err <- peek errPtr - peekCString (c'git_error'message err) -- failure (f (pack errStr)) -+ throwM (f (pack errStr)) - - -- withLgTempRepo :: MonadLg m => ReaderT LgRepo m a -> m a - -- withLgTempRepo f = withTempDir $ \dir -> do -@@ -1048,13 +1047,13 @@ - -- (Either Git.SHA ByteString)) m - -- (Git.TreeFilePath, Either Git.SHA ByteString) - handlePath (Right _) = -- lift $ failure $ Git.DiffTreeToIndexFailed -+ lift $ throwM $ Git.DiffTreeToIndexFailed - "Received a Right value when a Left RawFilePath was expected" - handlePath (Left path) = do - mcontent <- await - case mcontent of - Nothing -> -- lift $ failure $ Git.DiffTreeToIndexFailed $ -+ lift $ throwM $ Git.DiffTreeToIndexFailed $ - "Content not provided for " <> T.pack (show path) - Just x -> handleContent path x - -@@ -1064,11 +1063,11 @@ - -- (Either Git.SHA ByteString)) m - -- (Git.TreeFilePath, Either Git.SHA ByteString) - handleContent _path (Left _) = -- lift $ failure $ Git.DiffTreeToIndexFailed -+ lift $ throwM $ Git.DiffTreeToIndexFailed - "Received a Left value when a Right ByteString was expected" - handleContent path (Right content) = return (path, content) - -- -- diffBlob :: Failure Git.GitException m -+ -- diffBlob :: MonadThrow m - -- => Git.TreeFilePath - -- -> Maybe (Either Git.SHA ByteString) - -- -> Maybe (ForeignPtr C'git_oid) -@@ -1183,8 +1182,8 @@ - B.cons (fromIntegral lineOrigin) bs - return 0 - --checkResult :: (Eq a, Num a, Failure Git.GitException m) => a -> Text -> m () --checkResult r why = when (r /= 0) $ failure (Git.BackendError why) -+checkResult :: (Eq a, Num a, MonadThrow m) => a -> Text -> m () -+checkResult r why = when (r /= 0) $ throwM (Git.BackendError why) - - lgBuildPackFile :: MonadLg m - => FilePath -> [Either CommitOid TreeOid] -@@ -1353,7 +1352,7 @@ - - lgLoadPackFileInMemory - :: (MonadBaseControl IO m, MonadIO m, MonadLogger m, -- Failure Git.GitException m) -+ MonadThrow m) - => FilePath - -> Ptr (Ptr C'git_odb_backend) - -> Ptr (Ptr C'git_odb) -@@ -1385,7 +1384,7 @@ - return odbPtr - - lgOpenPackFile :: (MonadBaseControl IO m, MonadIO m, MonadLogger m, -- Failure Git.GitException m) -+ MonadThrow m) - => FilePath -> m (Ptr C'git_odb) - lgOpenPackFile idxPath = control $ \run -> - alloca $ \odbPtrPtr -> -@@ -1393,17 +1392,17 @@ - lgLoadPackFileInMemory idxPath backendPtrPtr odbPtrPtr - - lgClosePackFile :: (MonadBaseControl IO m, MonadIO m, MonadLogger m, -- Failure Git.GitException m) -+ MonadThrow m) - => Ptr C'git_odb -> m () - lgClosePackFile = liftIO . c'git_odb_free - - lgWithPackFile :: (MonadBaseControl IO m, MonadIO m, MonadLogger m, -- Failure Git.GitException m) -+ MonadThrow m) - => FilePath -> (Ptr C'git_odb -> m a) -> m a - lgWithPackFile idxPath = bracket (lgOpenPackFile idxPath) lgClosePackFile - - lgReadFromPack :: (MonadBaseControl IO m, MonadIO m, MonadLogger m, -- Failure Git.GitException m) -+ MonadThrow m) - => Ptr C'git_odb -> Git.SHA -> Bool - -> m (Maybe (C'git_otype, CSize, ByteString)) - lgReadFromPack odbPtr sha metadataOnly = liftIO $ do -diff -ru orig/gitlib-libgit2.cabal new/gitlib-libgit2.cabal ---- orig/gitlib-libgit2.cabal 2014-04-06 09:02:46.527789820 +0300 -+++ new/gitlib-libgit2.cabal 2014-04-06 09:02:46.000000000 +0300 -@@ -42,7 +42,6 @@ - , conduit >= 0.5.5 - , containers >= 0.4.2.1 - , directory >= 1.1.0.2 -- , failure >= 0.2.0.1 - , fast-logger - , filepath >= 1.3.0 - , lifted-async >= 0.1.0 diff --git a/patching/patches/gitlib-s3-3.0.2.patch b/patching/patches/gitlib-s3-3.0.2.patch deleted file mode 100644 index 26aedd9f..00000000 --- a/patching/patches/gitlib-s3-3.0.2.patch +++ /dev/null @@ -1,276 +0,0 @@ -diff -ru orig/Git/S3.hs new/Git/S3.hs ---- orig/Git/S3.hs 2014-04-06 09:02:47.247789820 +0300 -+++ new/Git/S3.hs 2014-04-06 09:02:47.000000000 +0300 -@@ -42,7 +42,6 @@ - import Control.Monad.Trans.Resource - import Control.Retry - import Data.Aeson as A --import Data.Attempt - import Data.Bifunctor - import Data.Binary as Bin - import Data.ByteString (ByteString) -@@ -141,7 +140,7 @@ - } - deriving (Eq, Show, Generic) - --type MonadS3 m = (Failure Git.GitException m, -+type MonadS3 m = (MonadThrow m, - MonadIO m, MonadBaseControl IO m, MonadLogger m) - - data BackendCallbacks = BackendCallbacks -@@ -478,7 +477,10 @@ - -> ResourceT m (Response (ResponseMetadata a) a) - awsRetry cfg svcfg mgr r = - transResourceT liftIO $ -- retrying def (isFailure . responseResult) $ aws cfg svcfg mgr r -+ retrying def (isLeft . responseResult) $ aws cfg svcfg mgr r -+ where -+ isLeft Left{} = True -+ isLeft Right{} = False - - listBucketS3 :: MonadS3 m => OdbS3Details -> ResourceT m [Text] - listBucketS3 dets = do -@@ -622,7 +624,7 @@ - sha <- oidToSha oid - modifyIORef mshas (sha:) - return c'GIT_OK -- checkResult r "lgForEachObject failed" -+ either throwM return $ checkResult r "lgForEachObject failed" - - -- Update the known objects map with the fact that we've got a local cache - -- of the pack file. -@@ -637,7 +639,7 @@ - ++ show (Prelude.length shas) ++ " objects" - return shas - --catalogPackFile :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+catalogPackFile :: (MonadS3 m, MonadThrow m) - => OdbS3Details -> Text -> FilePath -> m [SHA] - catalogPackFile dets packSha idxPath = do - -- Load the pack file, and iterate over the objects within it to determine -@@ -710,7 +712,7 @@ - lgDebug $ "cacheUpdateEntry " ++ show (shaToText sha) ++ " " ++ show ce - liftIO $ atomically $ modifyTVar (knownObjects dets) $ M.insert sha ce - --cacheLoadObject :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+cacheLoadObject :: (MonadS3 m, MonadThrow m) - => OdbS3Details -> SHA -> CacheEntry -> Bool - -> m (Maybe ObjectInfo) - cacheLoadObject dets sha ce metadataOnly = do -@@ -958,7 +960,7 @@ - remoteStoreObject _ _ _ = - throw (Git.BackendError "remoteStoreObject was not given any data") - --remoteCatalogContents :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+remoteCatalogContents :: (MonadS3 m, MonadThrow m) - => OdbS3Details -> ResourceT m () - remoteCatalogContents dets = do - lgDebug "remoteCatalogContents" -@@ -982,7 +984,7 @@ - - | otherwise -> return () - --accessObject :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+accessObject :: (MonadS3 m, MonadThrow m) - => OdbS3Details -> SHA -> Bool -> m (Maybe CacheEntry) - accessObject dets sha checkRemote = do - mentry <- cacheLookupEntry dets sha -@@ -1032,19 +1034,19 @@ - -- cache and with the callback interface. This is to avoid recataloging - -- in the future. - --objectExists :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+objectExists :: (MonadS3 m, MonadThrow m) - => OdbS3Details -> SHA -> Bool -> m CacheEntry - objectExists dets sha checkRemote = do - mce <- accessObject dets sha checkRemote - return $ fromMaybe DoesNotExist mce - --readObject :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+readObject :: (MonadS3 m, MonadThrow m) - => OdbS3Details -> SHA -> Bool -> m (Maybe ObjectInfo) - readObject dets sha metadataOnly = do - ce <- objectExists dets sha True - cacheLoadObject dets sha ce metadataOnly `orElse` return Nothing - --readObjectMetadata :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+readObjectMetadata :: (MonadS3 m, MonadThrow m) - => OdbS3Details -> SHA -> m (Maybe ObjectInfo) - readObjectMetadata dets sha = readObject dets sha True - -@@ -1054,7 +1056,7 @@ - callbackRegisterObject dets sha info - cacheStoreObject dets sha info - --writePackFile :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+writePackFile :: (MonadS3 m, MonadThrow m) - => OdbS3Details -> BL.ByteString -> m () - writePackFile dets bytes = do - let dir = tempDirectory dets -@@ -1073,7 +1075,7 @@ - shas <- catalogPackFile dets packSha idxPath - callbackRegisterPackFile dets packSha shas - --readCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+readCallback :: (MonadS3 m, MonadThrow m) - => Ptr (Ptr ()) - -> Ptr CSize - -> Ptr C'git_otype -@@ -1104,7 +1106,7 @@ - BU.unsafeUseAsCString chunk $ copyBytes p ?? len - return $ p `plusPtr` len - --readPrefixCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+readPrefixCallback :: (MonadS3 m, MonadThrow m) - => Ptr C'git_oid - -> Ptr (Ptr ()) - -> Ptr CSize -@@ -1140,7 +1142,7 @@ - go dets sha False - | otherwise = return Nothing - --readHeaderCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+readHeaderCallback :: (MonadS3 m, MonadThrow m) - => Ptr CSize - -> Ptr C'git_otype - -> Ptr C'git_odb_backend -@@ -1158,7 +1160,7 @@ - poke len_p (toLength len) - poke type_p (toType typ) - --writeCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+writeCallback :: (MonadS3 m, MonadThrow m) - => Ptr C'git_oid - -> Ptr C'git_odb_backend - -> Ptr () -@@ -1184,7 +1186,7 @@ - (ObjectInfo (fromLength len) (fromType obj_type) - Nothing (Just (BL.fromChunks [bytes]))) - --existsCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+existsCallback :: (MonadS3 m, MonadThrow m) - => Ptr C'git_odb_backend -> Ptr C'git_oid -> CInt -> m CInt - existsCallback be oid confirmNotExists = do - (dets, sha) <- liftIO $ unpackDetails be oid -@@ -1194,18 +1196,18 @@ - return $ if ce == DoesNotExist then 0 else 1) - (return c'GIT_ERROR) - --refreshCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+refreshCallback :: (MonadS3 m, MonadThrow m) - => Ptr C'git_odb_backend -> m CInt - refreshCallback _ = - return c'GIT_OK -- do nothing - --foreachCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+foreachCallback :: (MonadS3 m, MonadThrow m) - => Ptr C'git_odb_backend -> C'git_odb_foreach_cb -> Ptr () - -> m CInt - foreachCallback _be _callback _payload = - return c'GIT_ERROR -- fallback to standard method - --writePackCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+writePackCallback :: (MonadS3 m, MonadThrow m) - => Ptr (Ptr C'git_odb_writepack) - -> Ptr C'git_odb_backend - -> C'git_transfer_progress_callback -@@ -1248,7 +1250,7 @@ - foreign import ccall "&freeCallback" - freeCallbackPtr :: FunPtr F'git_odb_backend_free_callback - --packAddCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+packAddCallback :: (MonadS3 m, MonadThrow m) - => Ptr C'git_odb_writepack - -> Ptr () - -> CSize -@@ -1267,7 +1269,7 @@ - (castPtr dataPtr) (fromIntegral len) - writePackFile dets (BL.fromChunks [bytes]) - --packCommitCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+packCommitCallback :: (MonadS3 m, MonadThrow m) - => Ptr C'git_odb_writepack -> Ptr C'git_transfer_progress - -> m CInt - packCommitCallback _wp _progress = -@@ -1380,7 +1382,7 @@ - liftIO $ writeIORef result res - readIORef result - --odbS3Backend :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+odbS3Backend :: (MonadS3 m, MonadThrow m) - => Aws.S3Configuration NormalQuery - -> Configuration - -> Manager -@@ -1475,7 +1477,7 @@ - - -- | Given a repository object obtained from Libgit2, add an S3 backend to it, - -- making it the primary store for objects associated with that repository. --addS3Backend :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+addS3Backend :: (MonadS3 m, MonadThrow m) - => LgRepo - -> Text -- ^ bucket - -> Text -- ^ prefix -@@ -1505,7 +1507,7 @@ - void $ liftIO $ odbBackendAdd repo odbS3 100 - return repo - --s3Factory :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+s3Factory :: (MonadS3 m, MonadThrow m) - => Maybe Text -> Text -> Text -> FilePath -> BackendCallbacks - -> Git.RepositoryFactory (ReaderT LgRepo (NoLoggingT m)) m LgRepo - s3Factory bucket accessKey secretKey dir callbacks = lgFactory -@@ -1528,7 +1530,7 @@ - dir - callbacks - --s3FactoryLogger :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) -+s3FactoryLogger :: (MonadS3 m, MonadThrow m) - => Maybe Text -> Text -> Text -> FilePath -> BackendCallbacks - -> Git.RepositoryFactory (ReaderT LgRepo m) m LgRepo - s3FactoryLogger bucket accessKey secretKey dir callbacks = lgFactoryLogger -diff -ru orig/gitlib-s3.cabal new/gitlib-s3.cabal ---- orig/gitlib-s3.cabal 2014-04-06 09:02:47.247789820 +0300 -+++ new/gitlib-s3.cabal 2014-04-06 09:02:47.000000000 +0300 -@@ -33,7 +33,6 @@ - , hspec-expectations >= 0.3 - , data-default >= 0.5.1 - , directory >= 1.1.0.2 -- , failure >= 0.2.0.1 - , filepath >= 1.3.0 - , monad-logger >= 0.3.1.1 - , resourcet >= 0.4.6 -@@ -52,12 +51,12 @@ - , ghc-prim - , hlibgit2 >= 0.18.0.11 - , aeson >= 0.6.1.0 -- , attempt >= 0.4.0 - , aws >= 0.7.5 - , bifunctors >= 3.2.0.1 - , binary >= 0.5.1.0 - , bytestring >= 0.9.2.1 - , conduit >= 0.5.5 -+ , conduit-extra - , data-default >= 0.5.1 - , directory >= 1.1.0.2 - , filepath >= 1.3.0 -diff -ru orig/test/Smoke.hs new/test/Smoke.hs ---- orig/test/Smoke.hs 2014-04-06 09:02:47.247789820 +0300 -+++ new/test/Smoke.hs 2014-04-06 09:02:47.000000000 +0300 -@@ -11,7 +11,6 @@ - - import Aws - import Control.Applicative --import Control.Failure - import Control.Monad.IO.Class - import Control.Monad.Logger - import Control.Monad.Trans.Reader -@@ -30,8 +29,7 @@ - import Test.Hspec.Runner - - s3Factory -- :: (Failure Git.GitException m, MonadIO m, MonadBaseControl IO m, -- MonadUnsafeIO m, MonadThrow m) -+ :: (MonadThrow m, MonadIO m, MonadBaseControl IO m) - => Git.RepositoryFactory (ReaderT Lg.LgRepo (NoLoggingT m)) m Lg.LgRepo - s3Factory = Lg.lgFactory - { Git.runRepository = \ctxt m -> diff --git a/patching/patches/gitlib-test-3.0.1.patch b/patching/patches/gitlib-test-3.0.1.patch deleted file mode 100644 index e825eb66..00000000 --- a/patching/patches/gitlib-test-3.0.1.patch +++ /dev/null @@ -1,11 +0,0 @@ -diff -ru orig/gitlib-test.cabal new/gitlib-test.cabal ---- orig/gitlib-test.cabal 2014-04-06 09:02:47.671789820 +0300 -+++ new/gitlib-test.cabal 2014-04-06 09:02:47.000000000 +0300 -@@ -28,6 +28,7 @@ - , bytestring - , failure >= 0.2.0 - , conduit -+ , conduit-extra - , monad-control >= 0.3.1 - , tagged >= 0.4.4 - , text >= 0.11.2 diff --git a/patching/patches/haskell-names-0.3.2.6.patch b/patching/patches/haskell-names-0.3.2.6.patch deleted file mode 100644 index d585b44e..00000000 --- a/patching/patches/haskell-names-0.3.2.6.patch +++ /dev/null @@ -1,12 +0,0 @@ -diff -ru orig/haskell-names.cabal new/haskell-names.cabal ---- orig/haskell-names.cabal 2014-03-06 15:00:30.424709530 +0200 -+++ new/haskell-names.cabal 2014-03-06 15:00:30.000000000 +0200 -@@ -271,7 +271,7 @@ - , data-lens-template - , tagged - , traverse-with-class -- , type-eq == 0.4 -+ , type-eq >= 0.4 - , Cabal >= 1.14 && < 1.20 - Hs-source-dirs: src - Ghc-options: -Wall -fno-warn-name-shadowing diff --git a/patching/patches/haskell-packages-0.2.3.3.patch b/patching/patches/haskell-packages-0.2.3.3.patch deleted file mode 100644 index 30f4b4fd..00000000 --- a/patching/patches/haskell-packages-0.2.3.3.patch +++ /dev/null @@ -1,11 +0,0 @@ -diff -ru orig/haskell-packages.cabal new/haskell-packages.cabal ---- orig/haskell-packages.cabal 2014-02-20 12:04:23.945608732 +0200 -+++ new/haskell-packages.cabal 2014-02-20 12:04:23.000000000 +0200 -@@ -48,6 +48,6 @@ - , containers - , mtl >= 2.1 - , hse-cpp -- , EitherT -+ , either - , haskell-src-exts >= 1.14 - , tagged diff --git a/patching/patches/hdaemonize-0.4.5.0.patch b/patching/patches/hdaemonize-0.4.5.0.patch deleted file mode 100644 index 9cb43814..00000000 --- a/patching/patches/hdaemonize-0.4.5.0.patch +++ /dev/null @@ -1,12 +0,0 @@ -diff -ruN orig/System/Posix/Daemonize.hs new/System/Posix/Daemonize.hs ---- orig/System/Posix/Daemonize.hs 2014-08-10 13:47:22.378323475 +0300 -+++ new/System/Posix/Daemonize.hs 2014-08-10 13:47:22.000000000 +0300 -@@ -147,7 +147,7 @@ - process daemon' args - where - -- program' daemon = withSyslog (fromJust $ name daemon) (syslogOptions daemon) DAEMON $ -+ program' daemon = withSyslog (fromJust $ name daemon) (syslogOptions daemon) DAEMON [] $ - do let log = syslog Notice - log "starting" - pidWrite daemon diff --git a/patching/patches/heist-0.13.0.6.patch b/patching/patches/heist-0.13.0.6.patch deleted file mode 100644 index 07236fb5..00000000 --- a/patching/patches/heist-0.13.0.6.patch +++ /dev/null @@ -1,12 +0,0 @@ -diff -ru orig/heist.cabal new/heist.cabal ---- orig/heist.cabal 2014-03-13 06:02:39.554055215 +0200 -+++ new/heist.cabal 2014-03-13 06:02:39.000000000 +0200 -@@ -153,7 +153,7 @@ - filepath >= 1.3 && < 1.4, - hashable >= 1.1 && < 1.3, - mtl >= 2.0 && < 2.2, -- process >= 1.1 && < 1.2, -+ process >= 1.1 && < 1.3, - random >= 1.0.1.0 && < 1.1, - text >= 0.10 && < 1.2, - time >= 1.1 && < 1.5, diff --git a/patching/patches/hint-0.4.2.0.patch b/patching/patches/hint-0.4.2.0.patch deleted file mode 100644 index 785016fb..00000000 --- a/patching/patches/hint-0.4.2.0.patch +++ /dev/null @@ -1,21 +0,0 @@ -diff -ru orig/unit-tests/run-unit-tests.hs new/unit-tests/run-unit-tests.hs ---- orig/unit-tests/run-unit-tests.hs 2014-05-11 18:47:29.102698531 +0300 -+++ new/unit-tests/run-unit-tests.hs 2014-05-11 18:47:28.000000000 +0300 -@@ -191,7 +191,7 @@ - test_catch :: TestCase - test_catch = TestCase "catch" [] $ do - setImports ["Prelude"] -- succeeds (action `catch` handler) @@? "catch failed" -+ succeeds (action `MC.catch` handler) @@? "catch failed" - where handler DivideByZero = return "catched" - handler e = throwM e - action = do s <- eval "1 `div` 0 :: Int" -@@ -203,7 +203,7 @@ - liftIO $ do - r <- newEmptyMVar - let concurrent = runInterpreter (liftIO $ putMVar r False) -- `catch` \MultipleInstancesNotAllowed -> -+ `MC.catch` \MultipleInstancesNotAllowed -> - do liftIO $ putMVar r True - return $ Right () - _ <- forkIO $ concurrent >> return () diff --git a/patching/patches/hoogle-4.2.32.patch b/patching/patches/hoogle-4.2.32.patch deleted file mode 100644 index 9b94c3ba..00000000 --- a/patching/patches/hoogle-4.2.32.patch +++ /dev/null @@ -1,58 +0,0 @@ -diff -ru orig/src/General/Web.hs new/src/General/Web.hs ---- orig/src/General/Web.hs 2014-06-09 15:25:38.583521732 +0300 -+++ new/src/General/Web.hs 2014-06-09 15:25:38.000000000 +0300 -@@ -21,6 +21,9 @@ - import General.Base - import System.FilePath - import Network.Wai -+#if MIN_VERSION_wai(3, 0, 0) -+import Data.IORef -+#endif - #if MIN_VERSION_wai(2, 0, 0) - import Network.Wai.Internal - #endif -@@ -46,7 +49,15 @@ - - responseFlatten :: Response -> IO (Status, ResponseHeaders, LBString) - responseFlatten r = do --#if MIN_VERSION_wai(2, 0, 0) -+#if MIN_VERSION_wai(3, 0, 0) -+ let (s,hs,withBody) = responseToStream r -+ ref <- newIORef mempty -+ let addChunk builder = modifyIORef ref (<> builder) -+ withBody $ \body -> body addChunk (return ()) -+ builder <- readIORef ref -+ let res = toLazyByteString builder -+ return (s,hs,res) -+#elif MIN_VERSION_wai(2, 0, 0) - let (s,hs,withSrc) = responseToSource r - chunks <- withSrc $ \src -> src $$ consume - let res = toLazyByteString $ mconcat [x | Chunk x <- chunks] -diff -ru orig/src/Web/Server.hs new/src/Web/Server.hs ---- orig/src/Web/Server.hs 2014-06-09 15:25:38.575521732 +0300 -+++ new/src/Web/Server.hs 2014-06-09 15:25:38.000000000 +0300 -@@ -32,14 +32,23 @@ - resp <- respArgs q - v <- newMVar () - putStrLn $ "Starting Hoogle Server on port " ++ show port -- runSettings defaultSettings{settingsOnException=exception, settingsPort=port} $ \r -> liftIO $ do -+ runSettings defaultSettings{settingsOnException=exception, settingsPort=port} -+#if MIN_VERSION_wai(3, 0, 0) -+ $ \r sendResponse -> do -+#else -+ $ \r -> liftIO $ do -+#endif - start <- getCurrentTime - res <- talk resp q r - responseEvaluate res - stop <- getCurrentTime - let t = floor $ diffUTCTime stop start * 1000 - withMVar v $ const $ putStrLn $ bsUnpack (rawPathInfo r) ++ bsUnpack (rawQueryString r) ++ " ms:" ++ show t -+#if MIN_VERSION_wai(3, 0, 0) -+ sendResponse res -+#else - return res -+#endif - - - #if MIN_VERSION_wai(2, 0, 0) diff --git a/patching/patches/hweblib-0.6.1.patch b/patching/patches/hweblib-0.6.1.patch deleted file mode 100644 index 1105360b..00000000 --- a/patching/patches/hweblib-0.6.1.patch +++ /dev/null @@ -1,23 +0,0 @@ -diff -ru orig/src/Network/Parser/Mime.hs new/src/Network/Parser/Mime.hs ---- orig/src/Network/Parser/Mime.hs 2014-03-19 12:03:48.222054709 +0200 -+++ new/src/Network/Parser/Mime.hs 2014-03-19 12:03:47.000000000 +0200 -@@ -43,7 +43,7 @@ - _ -> MultiPart (Extension s) - (t, s) -> Other t s - where -- paired s = let (a,b) = (T.break (== '/') . T.toLower . TE.decodeLatin1) s in -+ paired s = let (a,b) = (T.break (== '/') . T.toLower . TE.decodeUtf8) s in - (a, T.drop 1 b) - - -- Parse headers and map them to a MimeValue -@@ -53,8 +53,8 @@ - let mv = L.foldl f nullMimeValue eh - return mv - where -- bs2t = M.fromList . Prelude.map (TE.decodeLatin1 *** TE.decodeLatin1) . M.toList -- hVal = TE.decodeLatin1 . hValue -+ bs2t = M.fromList . Prelude.map (TE.decodeUtf8 *** TE.decodeUtf8) . M.toList -+ hVal = TE.decodeUtf8 . hValue - f z x = - case hType x of - IdH -> z { mvHeaders = M.insert IdH (hVal x) (mvHeaders z) } diff --git a/patching/patches/incremental-parser-0.2.3.2.patch b/patching/patches/incremental-parser-0.2.3.2.patch deleted file mode 100644 index 82ca2275..00000000 --- a/patching/patches/incremental-parser-0.2.3.2.patch +++ /dev/null @@ -1,20 +0,0 @@ -diff -ru orig/incremental-parser.cabal new/incremental-parser.cabal ---- orig/incremental-parser.cabal 2014-06-15 10:20:01.864931460 +0300 -+++ new/incremental-parser.cabal 2014-06-15 10:20:01.000000000 +0300 -@@ -29,15 +29,3 @@ - GHC-prof-options: -auto-all - if impl(ghc >= 7.0.0) - default-language: Haskell2010 -- --test-suite Main -- Type: exitcode-stdio-1.0 -- x-uses-tf: true -- Build-Depends: base < 5, monoid-subclasses < 0.4, -- QuickCheck >= 2 && < 3, checkers >= 0.2 && < 0.4, -- test-framework >= 0.4.1, test-framework-quickcheck2 -- Main-is: Test/TestIncrementalParser.hs -- Other-Modules: Text.ParserCombinators.Incremental, -- Text.ParserCombinators.Incremental.LeftBiasedLocal, Text.ParserCombinators.Incremental.Symmetric, -- Control.Applicative.Monoid -- default-language: Haskell2010 -Only in orig: Test diff --git a/patching/patches/network-transport-tests-0.1.0.1.patch b/patching/patches/network-transport-tests-0.1.0.1.patch deleted file mode 100644 index 1e3f06df..00000000 --- a/patching/patches/network-transport-tests-0.1.0.1.patch +++ /dev/null @@ -1,12 +0,0 @@ -diff -ru orig/network-transport-tests.cabal new/network-transport-tests.cabal ---- orig/network-transport-tests.cabal 2014-03-25 06:24:53.648644213 +0200 -+++ new/network-transport-tests.cabal 2014-03-25 06:24:53.000000000 +0200 -@@ -24,7 +24,7 @@ - bytestring >= 0.9 && < 0.11, - random >= 1.0 && < 1.1, - mtl >= 2.1 && < 2.2, -- ansi-terminal >= 0.5 && < 0.6 -+ ansi-terminal >= 0.5 - hs-source-dirs: src - ghc-options: -Wall -fno-warn-unused-do-bind - extensions: CPP, diff --git a/patching/patches/primitive-0.5.3.0.patch b/patching/patches/primitive-0.5.3.0.patch deleted file mode 100644 index 592313e7..00000000 --- a/patching/patches/primitive-0.5.3.0.patch +++ /dev/null @@ -1,62 +0,0 @@ -diff -ruN orig/Control/Monad/Primitive.hs new/Control/Monad/Primitive.hs ---- orig/Control/Monad/Primitive.hs 2014-08-01 14:49:04.175318972 +0300 -+++ new/Control/Monad/Primitive.hs 2014-08-01 14:49:03.000000000 +0300 -@@ -44,7 +44,9 @@ - primitive_ :: PrimMonad m - => (State# (PrimState m) -> State# (PrimState m)) -> m () - {-# INLINE primitive_ #-} --primitive_ f = primitive (\s# -> (# f s#, () #)) -+primitive_ f = primitive (\s# -> -+ case f s# of -+ s'# -> (# s'#, () #)) - - instance PrimMonad IO where - type PrimState IO = RealWorld -diff -ruN orig/primitive.cabal new/primitive.cabal ---- orig/primitive.cabal 2014-08-01 14:49:04.175318972 +0300 -+++ new/primitive.cabal 2014-08-01 14:49:03.000000000 +0300 -@@ -50,6 +50,16 @@ - if arch(i386) || arch(x86_64) - cc-options: -msse2 - -+test-suite test -+ Default-Language: Haskell2010 -+ hs-source-dirs: test -+ main-is: main.hs -+ type: exitcode-stdio-1.0 -+ build-depends: base -+ , ghc-prim -+ , primitive -+ ghc-options: -O2 -+ - source-repository head - type: git - location: https://github.com/haskell/primitive -diff -ruN orig/test/main.hs new/test/main.hs ---- orig/test/main.hs 1970-01-01 02:00:00.000000000 +0200 -+++ new/test/main.hs 2014-08-01 14:49:03.000000000 +0300 -@@ -0,0 +1,24 @@ -+{-# LANGUAGE MagicHash, UnboxedTuples #-} -+import Control.Monad.Primitive -+import Data.Primitive.Array -+import GHC.IO -+import GHC.Prim -+ -+-- Since we only have a single test case right now, I'm going to avoid the -+-- issue of choosing a test framework for the moment. This also keeps the -+-- package as a whole light on dependencies. -+ -+main :: IO () -+main = do -+ arr <- newArray 1 'A' -+ let unit = -+ case writeArray arr 0 'B' of -+ IO f -> -+ case f realWorld# of -+ _ -> () -+ c1 <- readArray arr 0 -+ return $! unit -+ c2 <- readArray arr 0 -+ if c1 == 'A' && c2 == 'B' -+ then return () -+ else error $ "Expected AB, got: " ++ show (c1, c2) diff --git a/patching/patches/process-conduit-1.0.0.1.patch b/patching/patches/process-conduit-1.0.0.1.patch deleted file mode 100644 index 16ba9923..00000000 --- a/patching/patches/process-conduit-1.0.0.1.patch +++ /dev/null @@ -1,12 +0,0 @@ -Only in new: dist -diff -ru orig/process-conduit.cabal new/process-conduit.cabal ---- orig/process-conduit.cabal 2014-03-30 12:27:40.781431440 +0300 -+++ new/process-conduit.cabal 2014-03-30 12:27:40.000000000 +0300 -@@ -35,6 +35,7 @@ - , process >= 1.0 - , conduit == 1.0.* - , shakespeare-text >= 1.0 -+ , shakespeare - - ghc-options: -Wall - diff --git a/patching/patches/process-conduit-1.0.0.2.patch b/patching/patches/process-conduit-1.0.0.2.patch deleted file mode 100644 index 79939e21..00000000 --- a/patching/patches/process-conduit-1.0.0.2.patch +++ /dev/null @@ -1,62 +0,0 @@ -diff -ru orig/Data/Conduit/Process.hs new/Data/Conduit/Process.hs ---- orig/Data/Conduit/Process.hs 2014-04-03 08:26:07.254383579 +0300 -+++ new/Data/Conduit/Process.hs 2014-04-03 08:26:06.000000000 +0300 -@@ -21,6 +21,7 @@ - import Control.Monad - import Control.Monad.Trans - import Control.Monad.Trans.Loop -+import Control.Monad.Trans.Resource (MonadResource, monadThrow) - import qualified Data.ByteString as S - import Data.Conduit - import qualified Data.Conduit.List as CL -diff -ru orig/process-conduit.cabal new/process-conduit.cabal ---- orig/process-conduit.cabal 2014-04-03 08:26:07.258383579 +0300 -+++ new/process-conduit.cabal 2014-04-03 08:26:06.000000000 +0300 -@@ -33,7 +33,8 @@ - , bytestring >= 0.9 - , text >= 0.11 - , process >= 1.0 -- , conduit == 1.0.* -+ , conduit >= 1.0 && < 1.2 -+ , resourcet >= 0.4 && < 1.2 - , shakespeare-text >= 1.0 - , shakespeare - -@@ -47,4 +48,6 @@ - , bytestring - , hspec >= 1.3 - , conduit -+ , conduit-extra -+ , resourcet - , process-conduit -diff -ru orig/System/Process/QQ.hs new/System/Process/QQ.hs ---- orig/System/Process/QQ.hs 2014-04-03 08:26:07.254383579 +0300 -+++ new/System/Process/QQ.hs 2014-04-03 08:26:06.000000000 +0300 -@@ -14,6 +14,7 @@ - import qualified Data.Text.Lazy as LT - import Language.Haskell.TH.Quote - import Text.Shakespeare.Text -+import Control.Monad.Trans.Resource (runResourceT) - - import Data.Conduit.Process - -@@ -28,7 +29,7 @@ - -- | Command result of (Lazy) ByteString. - cmd :: QuasiQuoter - cmd = def { quoteExp = \str -> [| -- BL.fromChunks <$> C.runResourceT (sourceCmd (LT.unpack $(quoteExp lt str)) C.$$ CL.consume) -+ BL.fromChunks <$> runResourceT (sourceCmd (LT.unpack $(quoteExp lt str)) C.$$ CL.consume) - |] } - - -- | Source of shell command -diff -ru orig/test.hs new/test.hs ---- orig/test.hs 2014-04-03 08:26:07.254383579 +0300 -+++ new/test.hs 2014-04-03 08:26:06.000000000 +0300 -@@ -7,6 +7,7 @@ - import Data.Conduit - import qualified Data.Conduit.Binary as CB - import Test.Hspec -+import Control.Monad.Trans.Resource (runResourceT) - - main :: IO () - main = hspec $ do diff --git a/patching/patches/process-conduit-1.1.0.0.patch b/patching/patches/process-conduit-1.1.0.0.patch deleted file mode 100644 index d3973788..00000000 --- a/patching/patches/process-conduit-1.1.0.0.patch +++ /dev/null @@ -1,21 +0,0 @@ -diff -ru orig/process-conduit.cabal new/process-conduit.cabal ---- orig/process-conduit.cabal 2014-04-04 10:13:39.716407142 +0300 -+++ new/process-conduit.cabal 2014-04-04 10:13:39.000000000 +0300 -@@ -48,4 +48,6 @@ - , bytestring - , hspec >= 1.3 - , conduit -+ , conduit-extra -+ , resourcet - , process-conduit -diff -ru orig/test.hs new/test.hs ---- orig/test.hs 2014-04-04 10:13:39.692407142 +0300 -+++ new/test.hs 2014-04-04 10:13:39.000000000 +0300 -@@ -5,6 +5,7 @@ - - import qualified Data.ByteString.Lazy.Char8 as L - import Data.Conduit -+import Control.Monad.Trans.Resource (runResourceT) - import qualified Data.Conduit.Binary as CB - import Test.Hspec - diff --git a/patching/patches/retry-0.4.patch b/patching/patches/retry-0.4.patch deleted file mode 100644 index 42989f49..00000000 --- a/patching/patches/retry-0.4.patch +++ /dev/null @@ -1,12 +0,0 @@ -diff -ru orig/retry.cabal new/retry.cabal ---- orig/retry.cabal 2014-05-11 11:28:24.319992770 +0300 -+++ new/retry.cabal 2014-05-11 11:28:24.000000000 +0300 -@@ -30,7 +30,7 @@ - exposed-modules: Control.Retry - build-depends: - base ==4.*, -- exceptions >= 0.5 && < 0.6, -+ exceptions >= 0.5 && < 0.7, - transformers, - data-default - hs-source-dirs: src diff --git a/patching/patches/retry-0.5.patch b/patching/patches/retry-0.5.patch deleted file mode 100644 index dbc4e219..00000000 --- a/patching/patches/retry-0.5.patch +++ /dev/null @@ -1,19 +0,0 @@ -diff -ruN orig/retry.cabal new/retry.cabal ---- orig/retry.cabal 2014-08-05 09:28:48.350961123 +0300 -+++ new/retry.cabal 2014-08-05 09:28:48.000000000 +0300 -@@ -44,13 +44,13 @@ - ghc-options: -threaded - build-depends: - base ==4.* -- , exceptions >= 0.5 && < 0.6 -+ , exceptions >= 0.5 - , transformers - , data-default-class - , time - , QuickCheck >= 2.7 && < 2.8 - , HUnit >= 1.2.5.2 && < 1.3 -- , hspec >= 1.9 && < 1.10 -+ , hspec >= 1.9 - default-language: Haskell2010 - - diff --git a/patching/patches/scientific-0.2.0.1.patch b/patching/patches/scientific-0.2.0.1.patch deleted file mode 100644 index 875e8e83..00000000 --- a/patching/patches/scientific-0.2.0.1.patch +++ /dev/null @@ -1,14 +0,0 @@ -diff -ru orig/scientific.cabal new/scientific.cabal ---- orig/scientific.cabal 2014-03-06 14:57:06.880706336 +0200 -+++ new/scientific.cabal 2014-03-06 14:57:06.000000000 +0200 -@@ -47,8 +47,8 @@ - - build-depends: scientific - , base >= 4.3 && < 4.8 -- , tasty >= 0.3.1 && < 0.8 -- , tasty-smallcheck >= 0.2 && < 0.3 -+ , tasty >= 0.3.1 && < 0.9 -+ , tasty-smallcheck >= 0.2 && < 0.9 - , smallcheck >= 1.0 && < 1.2 - , text >= 0.8 && < 1.2 - diff --git a/patching/patches/snap-0.13.2.2.patch b/patching/patches/snap-0.13.2.2.patch deleted file mode 100644 index f2691db1..00000000 --- a/patching/patches/snap-0.13.2.2.patch +++ /dev/null @@ -1,12 +0,0 @@ -diff -ru orig/snap.cabal new/snap.cabal ---- orig/snap.cabal 2014-03-19 10:17:25.886213731 +0200 -+++ new/snap.cabal 2014-03-19 10:17:25.000000000 +0200 -@@ -154,7 +154,7 @@ - containers >= 0.3 && < 0.6, - directory >= 1.0 && < 1.3, - directory-tree >= 0.11 && < 0.12, -- dlist >= 0.5 && < 0.7, -+ dlist >= 0.5 && < 0.8, - errors >= 1.4 && < 1.5, - filepath >= 1.1 && < 1.4, - -- Blacklist bad versions of hashable diff --git a/patching/patches/sqlite-simple-0.4.5.1.patch b/patching/patches/sqlite-simple-0.4.5.1.patch deleted file mode 100644 index d6167f35..00000000 --- a/patching/patches/sqlite-simple-0.4.5.1.patch +++ /dev/null @@ -1,12 +0,0 @@ -diff -ru orig/Database/SQLite/Simple.hs new/Database/SQLite/Simple.hs ---- orig/Database/SQLite/Simple.hs 2014-02-14 14:38:24.411759783 +0200 -+++ new/Database/SQLite/Simple.hs 2014-02-14 14:38:24.000000000 +0200 -@@ -343,7 +343,7 @@ - | otherwise -> errorColumnMismatch (ColumnOutOfBounds col) - Errors [] -> throwIO $ ConversionFailed "" "" "unknown error" - Errors [x] -> -- throw x `catch` (\e -> errorColumnMismatch (e :: ColumnOutOfBounds)) -+ throw x `Control.Exception.catch` (\e -> errorColumnMismatch (e :: ColumnOutOfBounds)) - Errors xs -> throwIO $ ManyErrors xs - where - errorColumnMismatch :: ColumnOutOfBounds -> IO r diff --git a/patching/patches/statistics-0.10.5.2.patch b/patching/patches/statistics-0.10.5.2.patch deleted file mode 100644 index 1eef4498..00000000 --- a/patching/patches/statistics-0.10.5.2.patch +++ /dev/null @@ -1,705 +0,0 @@ -diff -ru orig/Statistics/Distribution/Beta.hs new/Statistics/Distribution/Beta.hs ---- orig/Statistics/Distribution/Beta.hs 2014-04-14 09:04:31.421509375 +0300 -+++ new/Statistics/Distribution/Beta.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -1,4 +1,4 @@ --{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-} - ----------------------------------------------------------------------------- - -- | - -- Module : Statistics.Distribution.Beta -@@ -27,6 +27,10 @@ - incompleteBeta, invIncompleteBeta, logBeta, digamma) - import Numeric.MathFunctions.Constants (m_NaN) - import qualified Statistics.Distribution as D -+#if !MIN_VERSION_binary(0, 6, 0) -+import Data.Binary (put, get) -+import Control.Applicative ((<$>), (<*>)) -+#endif - - -- | The beta distribution - data BetaDistribution = BD -@@ -36,7 +40,11 @@ - -- ^ Beta shape parameter - } deriving (Eq, Read, Show, Typeable, Data, Generic) - --instance Binary BetaDistribution -+instance Binary BetaDistribution where -+#if !MIN_VERSION_binary(0, 6, 0) -+ put (BD x y) = put x >> put y -+ get = BD <$> get <*> get -+#endif - - -- | Create beta distribution. Both shape parameters must be positive. - betaDistr :: Double -- ^ Shape parameter alpha -diff -ru orig/Statistics/Distribution/Binomial.hs new/Statistics/Distribution/Binomial.hs ---- orig/Statistics/Distribution/Binomial.hs 2014-04-14 09:04:31.421509375 +0300 -+++ new/Statistics/Distribution/Binomial.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -1,4 +1,4 @@ --{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-} - -- | - -- Module : Statistics.Distribution.Binomial - -- Copyright : (c) 2009 Bryan O'Sullivan -@@ -30,6 +30,10 @@ - import qualified Statistics.Distribution.Poisson.Internal as I - import Numeric.SpecFunctions (choose,incompleteBeta) - import Numeric.MathFunctions.Constants (m_epsilon) -+#if !MIN_VERSION_binary(0, 6, 0) -+import Data.Binary (put, get) -+import Control.Applicative ((<$>), (<*>)) -+#endif - - - -- | The binomial distribution. -@@ -40,7 +44,11 @@ - -- ^ Probability. - } deriving (Eq, Read, Show, Typeable, Data, Generic) - --instance Binary BinomialDistribution -+instance Binary BinomialDistribution where -+#if !MIN_VERSION_binary(0, 6, 0) -+ put (BD x y) = put x >> put y -+ get = BD <$> get <*> get -+#endif - - instance D.Distribution BinomialDistribution where - cumulative = cumulative -diff -ru orig/Statistics/Distribution/CauchyLorentz.hs new/Statistics/Distribution/CauchyLorentz.hs ---- orig/Statistics/Distribution/CauchyLorentz.hs 2014-04-14 09:04:31.421509375 +0300 -+++ new/Statistics/Distribution/CauchyLorentz.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -1,4 +1,4 @@ --{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-} - -- | - -- Module : Statistics.Distribution.CauchyLorentz - -- Copyright : (c) 2011 Aleksey Khudyakov -@@ -25,6 +25,10 @@ - import Data.Data (Data, Typeable) - import GHC.Generics (Generic) - import qualified Statistics.Distribution as D -+#if !MIN_VERSION_binary(0, 6, 0) -+import Data.Binary (put, get) -+import Control.Applicative ((<$>), (<*>)) -+#endif - - -- | Cauchy-Lorentz distribution. - data CauchyDistribution = CD { -@@ -39,7 +43,11 @@ - } - deriving (Eq, Show, Read, Typeable, Data, Generic) - --instance Binary CauchyDistribution -+instance Binary CauchyDistribution where -+#if !MIN_VERSION_binary(0, 6, 0) -+ put (CD x y) = put x >> put y -+ get = CD <$> get <*> get -+#endif - - -- | Cauchy distribution - cauchyDistribution :: Double -- ^ Central point -diff -ru orig/Statistics/Distribution/ChiSquared.hs new/Statistics/Distribution/ChiSquared.hs ---- orig/Statistics/Distribution/ChiSquared.hs 2014-04-14 09:04:31.421509375 +0300 -+++ new/Statistics/Distribution/ChiSquared.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -1,4 +1,4 @@ --{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-} - -- | - -- Module : Statistics.Distribution.ChiSquared - -- Copyright : (c) 2010 Alexey Khudyakov -@@ -26,13 +26,20 @@ - - import qualified Statistics.Distribution as D - import qualified System.Random.MWC.Distributions as MWC -+#if !MIN_VERSION_binary(0, 6, 0) -+import Data.Binary (put, get) -+#endif - - - -- | Chi-squared distribution - newtype ChiSquared = ChiSquared Int - deriving (Eq, Read, Show, Typeable, Data, Generic) - --instance Binary ChiSquared -+instance Binary ChiSquared where -+#if !MIN_VERSION_binary(0, 6, 0) -+ get = fmap ChiSquared get -+ put (ChiSquared x) = put x -+#endif - - -- | Get number of degrees of freedom - chiSquaredNDF :: ChiSquared -> Int -diff -ru orig/Statistics/Distribution/Exponential.hs new/Statistics/Distribution/Exponential.hs ---- orig/Statistics/Distribution/Exponential.hs 2014-04-14 09:04:31.421509375 +0300 -+++ new/Statistics/Distribution/Exponential.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -1,4 +1,4 @@ --{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-} - -- | - -- Module : Statistics.Distribution.Exponential - -- Copyright : (c) 2009 Bryan O'Sullivan -@@ -31,13 +31,20 @@ - import qualified Statistics.Sample as S - import qualified System.Random.MWC.Distributions as MWC - import Statistics.Types (Sample) -+#if !MIN_VERSION_binary(0, 6, 0) -+import Data.Binary (put, get) -+#endif - - - newtype ExponentialDistribution = ED { - edLambda :: Double - } deriving (Eq, Read, Show, Typeable, Data, Generic) - --instance Binary ExponentialDistribution -+instance Binary ExponentialDistribution where -+#if !MIN_VERSION_binary(0, 6, 0) -+ put = put . edLambda -+ get = fmap ED get -+#endif - - instance D.Distribution ExponentialDistribution where - cumulative = cumulative -diff -ru orig/Statistics/Distribution/FDistribution.hs new/Statistics/Distribution/FDistribution.hs ---- orig/Statistics/Distribution/FDistribution.hs 2014-04-14 09:04:31.421509375 +0300 -+++ new/Statistics/Distribution/FDistribution.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -1,4 +1,4 @@ --{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-} - -- | - -- Module : Statistics.Distribution.FDistribution - -- Copyright : (c) 2011 Aleksey Khudyakov -@@ -23,6 +23,10 @@ - import qualified Statistics.Distribution as D - import Numeric.SpecFunctions ( - logBeta, incompleteBeta, invIncompleteBeta, digamma) -+#if !MIN_VERSION_binary(0, 6, 0) -+import Data.Binary (put, get) -+import Control.Applicative ((<$>), (<*>)) -+#endif - - - -@@ -33,7 +37,11 @@ - } - deriving (Eq, Show, Read, Typeable, Data, Generic) - --instance Binary FDistribution -+instance Binary FDistribution where -+#if !MIN_VERSION_binary(0, 6, 0) -+ get = F <$> get <*> get <*> get -+ put (F x y z) = put x >> put y >> put z -+#endif - - fDistribution :: Int -> Int -> FDistribution - fDistribution n m -diff -ru orig/Statistics/Distribution/Gamma.hs new/Statistics/Distribution/Gamma.hs ---- orig/Statistics/Distribution/Gamma.hs 2014-04-14 09:04:31.421509375 +0300 -+++ new/Statistics/Distribution/Gamma.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -1,4 +1,4 @@ --{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-} - -- | - -- Module : Statistics.Distribution.Gamma - -- Copyright : (c) 2009, 2011 Bryan O'Sullivan -@@ -34,6 +34,10 @@ - import Statistics.Distribution.Poisson.Internal as Poisson - import qualified Statistics.Distribution as D - import qualified System.Random.MWC.Distributions as MWC -+#if !MIN_VERSION_binary(0, 6, 0) -+import Data.Binary (put, get) -+import Control.Applicative ((<$>), (<*>)) -+#endif - - -- | The gamma distribution. - data GammaDistribution = GD { -@@ -41,7 +45,11 @@ - , gdScale :: {-# UNPACK #-} !Double -- ^ Scale parameter, ϑ. - } deriving (Eq, Read, Show, Typeable, Data, Generic) - --instance Binary GammaDistribution -+instance Binary GammaDistribution where -+#if !MIN_VERSION_binary(0, 6, 0) -+ put (GD x y) = put x >> put y -+ get = GD <$> get <*> get -+#endif - - -- | Create gamma distribution. Both shape and scale parameters must - -- be positive. -diff -ru orig/Statistics/Distribution/Geometric.hs new/Statistics/Distribution/Geometric.hs ---- orig/Statistics/Distribution/Geometric.hs 2014-04-14 09:04:31.421509375 +0300 -+++ new/Statistics/Distribution/Geometric.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -1,4 +1,4 @@ --{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-} - -- | - -- Module : Statistics.Distribution.Geometric - -- Copyright : (c) 2009 Bryan O'Sullivan -@@ -37,6 +37,10 @@ - import Numeric.MathFunctions.Constants(m_pos_inf,m_neg_inf) - import qualified Statistics.Distribution as D - import qualified System.Random.MWC.Distributions as MWC -+#if !MIN_VERSION_binary(0, 6, 0) -+import Data.Binary (put, get) -+import Control.Applicative ((<$>)) -+#endif - - ---------------------------------------------------------------- - -- Distribution over [1..] -@@ -45,7 +49,11 @@ - gdSuccess :: Double - } deriving (Eq, Read, Show, Typeable, Data, Generic) - --instance Binary GeometricDistribution -+instance Binary GeometricDistribution where -+#if !MIN_VERSION_binary(0, 6, 0) -+ get = GD <$> get -+ put (GD x) = put x -+#endif - - instance D.Distribution GeometricDistribution where - cumulative = cumulative -@@ -115,7 +123,11 @@ - gdSuccess0 :: Double - } deriving (Eq, Read, Show, Typeable, Data, Generic) - --instance Binary GeometricDistribution0 -+instance Binary GeometricDistribution0 where -+#if !MIN_VERSION_binary(0, 6, 0) -+ get = GD0 <$> get -+ put (GD0 x) = put x -+#endif - - instance D.Distribution GeometricDistribution0 where - cumulative (GD0 s) x = cumulative (GD s) (x + 1) -diff -ru orig/Statistics/Distribution/Hypergeometric.hs new/Statistics/Distribution/Hypergeometric.hs ---- orig/Statistics/Distribution/Hypergeometric.hs 2014-04-14 09:04:31.421509375 +0300 -+++ new/Statistics/Distribution/Hypergeometric.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -1,4 +1,4 @@ --{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-} - -- | - -- Module : Statistics.Distribution.Hypergeometric - -- Copyright : (c) 2009 Bryan O'Sullivan -@@ -33,6 +33,10 @@ - import Numeric.MathFunctions.Constants (m_epsilon) - import Numeric.SpecFunctions (choose) - import qualified Statistics.Distribution as D -+#if !MIN_VERSION_binary(0, 6, 0) -+import Data.Binary (put, get) -+import Control.Applicative ((<$>), (<*>)) -+#endif - - data HypergeometricDistribution = HD { - hdM :: {-# UNPACK #-} !Int -@@ -40,7 +44,11 @@ - , hdK :: {-# UNPACK #-} !Int - } deriving (Eq, Read, Show, Typeable, Data, Generic) - --instance Binary HypergeometricDistribution -+instance Binary HypergeometricDistribution where -+#if !MIN_VERSION_binary(0, 6, 0) -+ get = HD <$> get <*> get <*> get -+ put (HD x y z) = put x >> put y >> put z -+#endif - - instance D.Distribution HypergeometricDistribution where - cumulative = cumulative -diff -ru orig/Statistics/Distribution/Normal.hs new/Statistics/Distribution/Normal.hs ---- orig/Statistics/Distribution/Normal.hs 2014-04-14 09:04:31.421509375 +0300 -+++ new/Statistics/Distribution/Normal.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -1,4 +1,4 @@ --{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric #-} -+{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, CPP #-} - -- | - -- Module : Statistics.Distribution.Normal - -- Copyright : (c) 2009 Bryan O'Sullivan -@@ -28,6 +28,8 @@ - import qualified Statistics.Distribution as D - import qualified Statistics.Sample as S - import qualified System.Random.MWC.Distributions as MWC -+import Data.Binary (put, get) -+import Control.Applicative ((<$>), (<*>)) - - - -@@ -39,7 +41,9 @@ - , ndCdfDenom :: {-# UNPACK #-} !Double - } deriving (Eq, Read, Show, Typeable, Data, Generic) - --instance Binary NormalDistribution -+instance Binary NormalDistribution where -+ put (ND w x y z) = put w >> put x >> put y >> put z -+ get = ND <$> get <*> get <*> get <*> get - - instance D.Distribution NormalDistribution where - cumulative = cumulative -diff -ru orig/Statistics/Distribution/Poisson/Internal.hs new/Statistics/Distribution/Poisson/Internal.hs ---- orig/Statistics/Distribution/Poisson/Internal.hs 2014-04-14 09:04:31.421509375 +0300 -+++ new/Statistics/Distribution/Poisson/Internal.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -36,8 +36,8 @@ - -- | Compute entropy using Theorem 1 from "Sharp Bounds on the Entropy - -- of the Poisson Law". This function is unused because 'directEntorpy' - -- is just as accurate and is faster by about a factor of 4. --alyThm1 :: Double -> Double --alyThm1 lambda = -+_alyThm1 :: Double -> Double -+_alyThm1 lambda = - sum (takeWhile (\x -> abs x >= m_epsilon * lll) alySeries) + lll - where lll = lambda * (1 - log lambda) - alySeries = -@@ -175,4 +175,4 @@ - | lambda <= 18 = alyThm2 lambda upperCoefficients6 lowerCoefficients6 - | lambda <= 24 = alyThm2 lambda upperCoefficients8 lowerCoefficients8 - | lambda <= 30 = alyThm2 lambda upperCoefficients10 lowerCoefficients10 -- | otherwise = alyThm2 lambda upperCoefficients12 lowerCoefficients12 -\ No newline at end of file -+ | otherwise = alyThm2 lambda upperCoefficients12 lowerCoefficients12 -diff -ru orig/Statistics/Distribution/Poisson.hs new/Statistics/Distribution/Poisson.hs ---- orig/Statistics/Distribution/Poisson.hs 2014-04-14 09:04:31.421509375 +0300 -+++ new/Statistics/Distribution/Poisson.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -1,4 +1,4 @@ --{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-} - -- | - -- Module : Statistics.Distribution.Poisson - -- Copyright : (c) 2009, 2011 Bryan O'Sullivan -@@ -31,13 +31,20 @@ - import qualified Statistics.Distribution.Poisson.Internal as I - import Numeric.SpecFunctions (incompleteGamma,logFactorial) - import Numeric.MathFunctions.Constants (m_neg_inf) -+#if !MIN_VERSION_binary(0, 6, 0) -+import Data.Binary (put, get) -+#endif - - - newtype PoissonDistribution = PD { - poissonLambda :: Double - } deriving (Eq, Read, Show, Typeable, Data, Generic) - --instance Binary PoissonDistribution -+instance Binary PoissonDistribution where -+#if !MIN_VERSION_binary(0, 6, 0) -+ get = fmap PD get -+ put = put . poissonLambda -+#endif - - instance D.Distribution PoissonDistribution where - cumulative (PD lambda) x -@@ -78,8 +85,9 @@ - poisson :: Double -> PoissonDistribution - poisson l - | l >= 0 = PD l -- | otherwise = error $ "Statistics.Distribution.Poisson.poisson:\ -- \ lambda must be non-negative. Got " ++ show l -+ | otherwise = error $ -+ "Statistics.Distribution.Poisson.poisson: lambda must be non-negative. Got " -+ ++ show l - {-# INLINE poisson #-} - - -- $references -diff -ru orig/Statistics/Distribution/StudentT.hs new/Statistics/Distribution/StudentT.hs ---- orig/Statistics/Distribution/StudentT.hs 2014-04-14 09:04:31.421509375 +0300 -+++ new/Statistics/Distribution/StudentT.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -1,4 +1,4 @@ --{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-} - -- | - -- Module : Statistics.Distribution.StudentT - -- Copyright : (c) 2011 Aleksey Khudyakov -@@ -23,12 +23,19 @@ - import Statistics.Distribution.Transform (LinearTransform (..)) - import Numeric.SpecFunctions ( - logBeta, incompleteBeta, invIncompleteBeta, digamma) -+#if !MIN_VERSION_binary(0, 6, 0) -+import Data.Binary (put, get) -+#endif - - -- | Student-T distribution - newtype StudentT = StudentT { studentTndf :: Double } - deriving (Eq, Show, Read, Typeable, Data, Generic) - --instance Binary StudentT -+instance Binary StudentT where -+#if !MIN_VERSION_binary(0, 6, 0) -+ put = put . studentTndf -+ get = fmap StudentT get -+#endif - - -- | Create Student-T distribution. Number of parameters must be positive. - studentT :: Double -> StudentT -diff -ru orig/Statistics/Distribution/Transform.hs new/Statistics/Distribution/Transform.hs ---- orig/Statistics/Distribution/Transform.hs 2014-04-14 09:04:31.421509375 +0300 -+++ new/Statistics/Distribution/Transform.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -1,5 +1,5 @@ - {-# LANGUAGE DeriveDataTypeable, DeriveGeneric, FlexibleContexts, -- FlexibleInstances, UndecidableInstances #-} -+ FlexibleInstances, UndecidableInstances, CPP #-} - -- | - -- Module : Statistics.Distribution.Transform - -- Copyright : (c) 2013 John McDonnell; -@@ -21,6 +21,10 @@ - import GHC.Generics (Generic) - import Data.Functor ((<$>)) - import qualified Statistics.Distribution as D -+#if !MIN_VERSION_binary(0, 6, 0) -+import Data.Binary (put, get) -+import Control.Applicative ((<*>)) -+#endif - - -- | Linear transformation applied to distribution. - -- -@@ -35,7 +39,11 @@ - -- ^ Distribution being transformed. - } deriving (Eq, Show, Read, Typeable, Data, Generic) - --instance (Binary d) => Binary (LinearTransform d) -+instance (Binary d) => Binary (LinearTransform d) where -+#if !MIN_VERSION_binary(0, 6, 0) -+ get = LinearTransform <$> get <*> get <*> get -+ put (LinearTransform x y z) = put x >> put y >> put z -+#endif - - -- | Apply linear transformation to distribution. - scaleAround :: Double -- ^ Fixed point -diff -ru orig/Statistics/Distribution/Uniform.hs new/Statistics/Distribution/Uniform.hs ---- orig/Statistics/Distribution/Uniform.hs 2014-04-14 09:04:31.421509375 +0300 -+++ new/Statistics/Distribution/Uniform.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -1,4 +1,4 @@ --{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-} - -- | - -- Module : Statistics.Distribution.Uniform - -- Copyright : (c) 2011 Aleksey Khudyakov -@@ -24,6 +24,10 @@ - import GHC.Generics (Generic) - import qualified Statistics.Distribution as D - import qualified System.Random.MWC as MWC -+#if !MIN_VERSION_binary(0, 6, 0) -+import Data.Binary (put, get) -+import Control.Applicative ((<$>), (<*>)) -+#endif - - - -- | Uniform distribution from A to B -@@ -32,7 +36,11 @@ - , uniformB :: {-# UNPACK #-} !Double -- ^ Upper boundary of distribution - } deriving (Eq, Read, Show, Typeable, Data, Generic) - --instance Binary UniformDistribution -+instance Binary UniformDistribution where -+#if !MIN_VERSION_binary(0, 6, 0) -+ put (UniformDistribution x y) = put x >> put y -+ get = UniformDistribution <$> get <*> get -+#endif - - -- | Create uniform distribution. - uniformDistr :: Double -> Double -> UniformDistribution -diff -ru orig/Statistics/Math/RootFinding.hs new/Statistics/Math/RootFinding.hs ---- orig/Statistics/Math/RootFinding.hs 2014-04-14 09:04:31.421509375 +0300 -+++ new/Statistics/Math/RootFinding.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -1,4 +1,4 @@ --{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric #-} -+{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, CPP #-} - - -- | - -- Module : Statistics.Math.RootFinding -@@ -27,6 +27,11 @@ - import Control.Monad (MonadPlus(..), ap) - import Data.Data (Data, Typeable) - import GHC.Generics (Generic) -+#if !MIN_VERSION_binary(0, 6, 0) -+import Data.Binary (put, get) -+import Data.Binary.Put (putWord8) -+import Data.Binary.Get (getWord8) -+#endif - - - -- | The result of searching for a root of a mathematical function. -@@ -40,7 +45,20 @@ - -- ^ A root was successfully found. - deriving (Eq, Read, Show, Typeable, Data, Generic) - --instance (Binary a) => Binary (Root a) -+instance (Binary a) => Binary (Root a) where -+#if !MIN_VERSION_binary(0, 6, 0) -+ put NotBracketed = putWord8 0 -+ put SearchFailed = putWord8 1 -+ put (Root a) = putWord8 2 >> put a -+ -+ get = do -+ i <- getWord8 -+ case i of -+ 0 -> return NotBracketed -+ 1 -> return SearchFailed -+ 2 -> fmap Root get -+ _ -> fail $ "Root.get: Invalid value: " ++ show i -+#endif - - instance Functor Root where - fmap _ NotBracketed = NotBracketed -diff -ru orig/Statistics/Resampling/Bootstrap.hs new/Statistics/Resampling/Bootstrap.hs ---- orig/Statistics/Resampling/Bootstrap.hs 2014-04-14 09:04:31.421509375 +0300 -+++ new/Statistics/Resampling/Bootstrap.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -1,5 +1,5 @@ - {-# LANGUAGE DeriveDataTypeable, DeriveGeneric, OverloadedStrings, -- RecordWildCards #-} -+ RecordWildCards, CPP #-} - - -- | - -- Module : Statistics.Resampling.Bootstrap -@@ -35,6 +35,10 @@ - import Statistics.Sample (mean) - import Statistics.Types (Estimator, Sample) - import qualified Data.Vector.Unboxed as U -+#if !MIN_VERSION_binary(0, 6, 0) -+import Data.Binary (put, get) -+import Control.Applicative ((<$>), (<*>)) -+#endif - - -- | A point and interval estimate computed via an 'Estimator'. - data Estimate = Estimate { -@@ -50,7 +54,11 @@ - -- ^ Confidence level of the confidence intervals. - } deriving (Eq, Read, Show, Typeable, Data, Generic) - --instance Binary Estimate -+instance Binary Estimate where -+#if !MIN_VERSION_binary(0, 6, 0) -+ put (Estimate w x y z) = put w >> put x >> put y >> put z -+ get = Estimate <$> get <*> get <*> get <*> get -+#endif - instance NFData Estimate - - -- | Multiply the point, lower bound, and upper bound in an 'Estimate' -diff -ru orig/Statistics/Resampling.hs new/Statistics/Resampling.hs ---- orig/Statistics/Resampling.hs 2014-04-14 09:04:31.421509375 +0300 -+++ new/Statistics/Resampling.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -1,4 +1,4 @@ --{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric #-} -+{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, CPP #-} - - -- | - -- Module : Statistics.Resampling -@@ -42,7 +42,11 @@ - fromResample :: U.Vector Double - } deriving (Eq, Read, Show, Typeable, Data, Generic) - --instance Binary Resample -+instance Binary Resample where -+#if !MIN_VERSION_binary(0, 6, 0) -+ put = put . fromResample -+ get = fmap Resample get -+#endif - - -- | /O(e*r*s)/ Resample a data set repeatedly, with replacement, - -- computing each estimate over the resampled data. -diff -ru orig/Statistics/Sample/KernelDensity/Simple.hs new/Statistics/Sample/KernelDensity/Simple.hs ---- orig/Statistics/Sample/KernelDensity/Simple.hs 2014-04-14 09:04:31.425509375 +0300 -+++ new/Statistics/Sample/KernelDensity/Simple.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -1,4 +1,4 @@ --{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, FlexibleContexts #-} -+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, FlexibleContexts, CPP #-} - -- | - -- Module : Statistics.Sample.KernelDensity.Simple - -- Copyright : (c) 2009 Bryan O'Sullivan -@@ -61,7 +61,11 @@ - fromPoints :: U.Vector Double - } deriving (Eq, Read, Show, Typeable, Data, Generic) - --instance Binary Points -+instance Binary Points where -+#if !MIN_VERSION_binary(0, 6, 0) -+ get = fmap Points get -+ put = put . fromPoints -+#endif - - -- | Bandwidth estimator for an Epanechnikov kernel. - epanechnikovBW :: Double -> Bandwidth -diff -ru orig/Statistics/Sample/Powers.hs new/Statistics/Sample/Powers.hs ---- orig/Statistics/Sample/Powers.hs 2014-04-14 09:04:31.421509375 +0300 -+++ new/Statistics/Sample/Powers.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -1,5 +1,5 @@ - {-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, -- FlexibleContexts #-} -+ FlexibleContexts, CPP #-} - -- | - -- Module : Statistics.Sample.Powers - -- Copyright : (c) 2009, 2010 Bryan O'Sullivan -@@ -65,7 +65,11 @@ - newtype Powers = Powers (U.Vector Double) - deriving (Eq, Read, Show, Typeable, Data, Generic) - --instance Binary Powers -+instance Binary Powers where -+#if !MIN_VERSION_binary(0, 6, 0) -+ put (Powers v) = put v -+ get = fmap Powers get -+#endif - - -- | O(/n/) Collect the /n/ simple powers of a sample. - -- -diff -ru orig/statistics.cabal new/statistics.cabal ---- orig/statistics.cabal 2014-04-14 09:04:31.429509375 +0300 -+++ new/statistics.cabal 2014-04-14 09:04:31.000000000 +0300 -@@ -90,7 +90,7 @@ - Statistics.Test.Internal - build-depends: - base < 5, -- binary >= 0.6.3.0, -+ binary >= 0.5.1.0, - deepseq >= 1.1.0.2, - erf, - monad-par >= 0.3.4, -diff -ru orig/tests/Tests/Distribution.hs new/tests/Tests/Distribution.hs ---- orig/tests/Tests/Distribution.hs 2014-04-14 09:04:31.425509375 +0300 -+++ new/tests/Tests/Distribution.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -188,7 +188,7 @@ - - -- Quantile is inverse of CDF - quantileIsInvCDF :: (Param d, ContDistr d) => T d -> d -> Double -> Property --quantileIsInvCDF _ d (snd . properFraction -> p) = -+quantileIsInvCDF _ d ((snd :: (Int, y) -> y) . properFraction -> p) = - p > 0 && p < 1 ==> ( printTestCase (printf "Quantile = %g" q ) - $ printTestCase (printf "Probability = %g" p ) - $ printTestCase (printf "Probability' = %g" p') -@@ -203,8 +203,8 @@ - quantileShouldFail :: (ContDistr d) => T d -> d -> Double -> Property - quantileShouldFail _ d p = - p < 0 || p > 1 ==> QC.monadicIO $ do r <- QC.run $ catch -- (do { return $! quantile d p; return False }) -- (\(e :: SomeException) -> return True) -+ (do { _ <- return $! quantile d p; return False }) -+ (\(_e :: SomeException) -> return True) - QC.assert r - - -diff -ru orig/tests/Tests/Function.hs new/tests/Tests/Function.hs ---- orig/tests/Tests/Function.hs 2014-04-14 09:04:31.425509375 +0300 -+++ new/tests/Tests/Function.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -1,7 +1,6 @@ - module Tests.Function ( tests ) where - - import qualified Data.Vector.Unboxed as U --import Data.Vector.Unboxed ((!)) - - import Test.QuickCheck - import Test.Framework -@@ -29,5 +28,5 @@ - p_nextHighestPowerOfTwo - = all (\(good, is) -> all ((==good) . nextHighestPowerOfTwo) is) lists - where -- pows = [1 .. 17] -+ pows = [1 .. 17 :: Int] - lists = [ (2^m, [2^n+1 .. 2^m]) | (n,m) <- pows `zip` tail pows ] -diff -ru orig/tests/Tests/Transform.hs new/tests/Tests/Transform.hs ---- orig/tests/Tests/Transform.hs 2014-04-14 09:04:31.425509375 +0300 -+++ new/tests/Tests/Transform.hs 2014-04-14 09:04:31.000000000 +0300 -@@ -15,7 +15,7 @@ - import Test.Framework (Test, testGroup) - import Test.Framework.Providers.QuickCheck2 (testProperty) - import Test.QuickCheck (Positive(..),Property,Arbitrary(..),Gen,choose,vectorOf, -- printTestCase, quickCheck) -+ printTestCase) - - import Text.Printf - diff --git a/patching/patches/stm-conduit-2.3.0.patch b/patching/patches/stm-conduit-2.3.0.patch deleted file mode 100644 index c06f61af..00000000 --- a/patching/patches/stm-conduit-2.3.0.patch +++ /dev/null @@ -1,16 +0,0 @@ -diff -ru orig/stm-conduit.cabal new/stm-conduit.cabal ---- orig/stm-conduit.cabal 2014-04-03 08:22:14.310388538 +0300 -+++ new/stm-conduit.cabal 2014-04-03 08:22:14.000000000 +0300 -@@ -29,9 +29,10 @@ - , stm-chans >= 2.0 && < 3.1 - , cereal >= 0.4.0.1 - , cereal-conduit >= 0.7.2 -- , conduit == 1.0.* -+ , conduit >= 1.0 && < 1.2 -+ , conduit-extra >= 1.0 && < 1.2 - , directory >= 1.1 -- , resourcet >= 0.3 && < 0.5 -+ , resourcet >= 0.3 && < 1.2 - , async >= 2.0.1 - , monad-control >= 0.3.2 - , monad-loops >= 0.4.2 diff --git a/patching/patches/stm-conduit-2.5.1.patch b/patching/patches/stm-conduit-2.5.1.patch deleted file mode 100644 index d7e9321e..00000000 --- a/patching/patches/stm-conduit-2.5.1.patch +++ /dev/null @@ -1,201 +0,0 @@ -diff -ruN orig/Data/Conduit/TMChan.hs new/Data/Conduit/TMChan.hs ---- orig/Data/Conduit/TMChan.hs 2014-08-27 18:36:44.141176333 +0300 -+++ new/Data/Conduit/TMChan.hs 2014-08-27 18:36:43.000000000 +0300 -@@ -63,22 +63,23 @@ - import Control.Concurrent.STM.TMChan - - import Data.Conduit --import Data.Conduit.Internal (Pipe (..), ConduitM (..)) -+import qualified Data.Conduit.List as CL - --chanSource -+chanSource - :: MonadIO m - => chan -- ^ The channel. - -> (chan -> STM (Maybe a)) -- ^ The 'read' function. - -> (chan -> STM ()) -- ^ The 'close' function. - -> Source m a --chanSource ch reader closer = ConduitM src -- where -- src = PipeM pull -- pull = do a <- liftSTM $ reader ch -- case a of -- Just x -> return $ HaveOutput src close x -- Nothing -> return $ Done () -- close = liftSTM $ closer ch -+chanSource ch reader closer = -+ loop -+ where -+ loop = do -+ a <- liftSTM $ reader ch -+ case a of -+ Just x -> yieldOr x close >> loop -+ Nothing -> return () -+ close = liftSTM $ closer ch - {-# INLINE chanSource #-} - - chanSink -@@ -87,13 +88,9 @@ - -> (chan -> a -> STM ()) -- ^ The 'write' function. - -> (chan -> STM ()) -- ^ The 'close' function. - -> Sink a m () --chanSink ch writer closer = ConduitM sink -- where -- sink = NeedInput push close -- -- push input = PipeM ((liftIO . atomically $ writer ch input) -- >> (return $ NeedInput push close)) -- close = const . liftSTM $ closer ch -+chanSink ch writer closer = do -+ CL.mapM_ $ liftIO . atomically . writer ch -+ liftSTM $ closer ch - {-# INLINE chanSink #-} - - -- | A simple wrapper around a TBMChan. As data is pushed into the channel, the -diff -ruN orig/Data/Conduit/TQueue.hs new/Data/Conduit/TQueue.hs ---- orig/Data/Conduit/TQueue.hs 2014-08-27 18:36:44.141176333 +0300 -+++ new/Data/Conduit/TQueue.hs 2014-08-27 18:36:43.000000000 +0300 -@@ -58,46 +58,28 @@ - import Control.Monad - import Control.Monad.IO.Class - import Data.Conduit --import Data.Conduit.Internal -+import qualified Data.Conduit.List as CL - - -- | A simple wrapper around a "TQueue". As data is pushed into the queue, the - -- source will read it and pass it down the conduit pipeline. - sourceTQueue :: MonadIO m => TQueue a -> Source m a --sourceTQueue q = ConduitM src -- where src = PipeM pull -- pull = do x <- liftSTM $ readTQueue q -- return $ HaveOutput src close x -- close = return () -+sourceTQueue q = forever $ liftSTM (readTQueue q) >>= yield - - -- | A simple wrapper around a "TQueue". As data is pushed into this sink, it - -- will magically begin to appear in the queue. - sinkTQueue :: MonadIO m => TQueue a -> Sink a m () --sinkTQueue q = ConduitM src -- where src = sink -- sink = NeedInput push close -- push input = PipeM ((liftSTM $ writeTQueue q input) -- >> (return $ NeedInput push close)) -- close _ = return () -+sinkTQueue q = CL.mapM_ (liftSTM . writeTQueue q) - - -- | A simple wrapper around a "TBQueue". As data is pushed into the queue, the - -- source will read it and pass it down the conduit pipeline. - sourceTBQueue :: MonadIO m => TBQueue a -> Source m a --sourceTBQueue q = ConduitM src -- where src = PipeM pull -- pull = do x <- liftSTM $ readTBQueue q -- return $ HaveOutput src close x -- close = return () -+sourceTBQueue q = forever $ liftSTM (readTBQueue q) >>= yield - - -- | A simple wrapper around a "TBQueue". As data is pushed into this sink, it - -- will magically begin to appear in the queue. Boolean argument is used - -- to specify if queue should be closed when the sink is closed. - sinkTBQueue :: MonadIO m => TBQueue a -> Sink a m () --sinkTBQueue q = ConduitM src -- where src = sink -- sink = NeedInput push close -- push input = PipeM ((liftSTM $ writeTBQueue q input) -- >> (return $ NeedInput push close)) -- close _ = return () -+sinkTBQueue q = CL.mapM_ (liftSTM . writeTBQueue q) - - -- | A convenience wrapper for creating a source and sink TBQueue of the given - -- size at once, without exposing the underlying queue. -@@ -109,14 +91,15 @@ - -- source will read it and pass it down the conduit pipeline. When the - -- queue is closed, the source will close also. - sourceTMQueue :: MonadIO m => TMQueue a -> Source m a --sourceTMQueue q = ConduitM src -- where src = PipeM pull -- pull = do mx <- liftSTM $ readTMQueue q -- case mx of -- Nothing -> return $ Done () -- Just x -> return $ HaveOutput src close x -- close = do liftSTM $ closeTMQueue q -- return () -+sourceTMQueue q = -+ loop -+ where -+ loop = do -+ mx <- liftSTM $ readTMQueue q -+ case mx of -+ Nothing -> return () -+ Just x -> yieldOr x close >> loop -+ close = liftSTM $ closeTMQueue q - - -- | A simple wrapper around a "TMQueue". As data is pushed into this sink, it - -- will magically begin to appear in the queue. -@@ -124,26 +107,23 @@ - => TMQueue a - -> Bool -- ^ Should the queue be closed when the sink is closed? - -> Sink a m () --sinkTMQueue q shouldClose = ConduitM src -- where src = sink -- sink = NeedInput push close -- push input = PipeM ((liftSTM $ writeTMQueue q input) -- >> (return $ NeedInput push close)) -- close _ = do when shouldClose (liftSTM $ closeTMQueue q) -- return () -+sinkTMQueue q shouldClose = do -+ CL.mapM_ (liftSTM . writeTMQueue q) -+ when shouldClose (liftSTM $ closeTMQueue q) - - -- | A simple wrapper around a "TBMQueue". As data is pushed into the queue, the - -- source will read it and pass it down the conduit pipeline. When the - -- queue is closed, the source will close also. - sourceTBMQueue :: MonadIO m => TBMQueue a -> Source m a --sourceTBMQueue q = ConduitM src -- where src = PipeM pull -- pull = do mx <- liftSTM $ readTBMQueue q -- case mx of -- Nothing -> return $ Done () -- Just x -> return $ HaveOutput src close x -- close = do liftSTM $ closeTBMQueue q -- return () -+sourceTBMQueue q = -+ loop -+ where -+ loop = do -+ mx <- liftSTM $ readTBMQueue q -+ case mx of -+ Nothing -> return () -+ Just x -> yieldOr x close >> loop -+ close = liftSTM $ closeTBMQueue q - - -- | A simple wrapper around a "TBMQueue". As data is pushed into this sink, it - -- will magically begin to appear in the queue. -@@ -151,13 +131,9 @@ - => TBMQueue a - -> Bool -- ^ Should the queue be closed when the sink is closed? - -> Sink a m () --sinkTBMQueue q shouldClose = ConduitM src -- where src = sink -- sink = NeedInput push close -- push input = PipeM ((liftSTM $ writeTBMQueue q input) -- >> (return $ NeedInput push close)) -- close _ = do when shouldClose (liftSTM $ closeTBMQueue q) -- return () -+sinkTBMQueue q shouldClose = do -+ CL.mapM_ (liftSTM . writeTBMQueue q) -+ when shouldClose (liftSTM $ closeTBMQueue q) - - - liftSTM :: forall (m :: * -> *) a. MonadIO m => STM a -> m a -diff -ruN orig/stm-conduit.cabal new/stm-conduit.cabal ---- orig/stm-conduit.cabal 2014-08-27 18:36:44.145176333 +0300 -+++ new/stm-conduit.cabal 2014-08-27 18:36:43.000000000 +0300 -@@ -29,7 +29,7 @@ - , stm-chans >= 2.0 && < 3.1 - , cereal >= 0.4.0.1 - , cereal-conduit >= 0.7.2 -- , conduit >= 1.0 && < 1.2 -+ , conduit >= 1.0 && < 1.3 - , conduit-extra >= 1.0 && < 1.2 - , directory >= 1.1 - , resourcet >= 0.3 && < 1.2 diff --git a/patching/patches/temporary-1.2.0.1.patch b/patching/patches/temporary-1.2.0.1.patch deleted file mode 100644 index 16d68bfd..00000000 --- a/patching/patches/temporary-1.2.0.1.patch +++ /dev/null @@ -1,12 +0,0 @@ -diff -ru orig/temporary.cabal new/temporary.cabal ---- orig/temporary.cabal 2014-04-03 08:17:21.902394760 +0300 -+++ new/temporary.cabal 2014-04-03 08:17:21.000000000 +0300 -@@ -23,7 +23,7 @@ - other-modules: Distribution.Compat.Exception - Distribution.Compat.TempFile - build-depends: base >= 3 && < 6, filepath >= 1.1 && < 1.4, directory >= 1.0 && < 1.3, -- transformers >= 0.2.0.0 && < 0.4, exceptions >= 0.1.1 && < 0.4 -+ transformers >= 0.2.0.0 && < 0.4, exceptions >= 0.1.1 && < 0.6 - - if !os(windows) - build-depends: unix >= 2.3 && < 2.8 diff --git a/patching/patches/temporary-1.2.0.2.patch b/patching/patches/temporary-1.2.0.2.patch deleted file mode 100644 index 3f258832..00000000 --- a/patching/patches/temporary-1.2.0.2.patch +++ /dev/null @@ -1,39 +0,0 @@ -diff -ru orig/System/IO/Temp.hs new/System/IO/Temp.hs ---- orig/System/IO/Temp.hs 2014-05-11 15:04:23.887266736 +0300 -+++ new/System/IO/Temp.hs 2014-05-11 15:04:23.000000000 +0300 -@@ -24,7 +24,7 @@ - -- - -- Behaves exactly the same as 'withTempFile', except that the parent temporary directory - -- will be that returned by 'getTemporaryDirectory'. --withSystemTempFile :: (MonadIO m, MonadCatch m) => -+withSystemTempFile :: (MonadIO m, MonadMask m) => - String -- ^ File name template. See 'openTempFile'. - -> (FilePath -> Handle -> m a) -- ^ Callback that can use the file - -> m a -@@ -34,7 +34,7 @@ - -- - -- Behaves exactly the same as 'withTempDirectory', except that the parent temporary directory - -- will be that returned by 'getTemporaryDirectory'. --withSystemTempDirectory :: (MonadIO m, MonadCatch m) => -+withSystemTempDirectory :: (MonadIO m, MonadMask m) => - String -- ^ Directory name template. See 'openTempFile'. - -> (FilePath -> m a) -- ^ Callback that can use the directory - -> m a -@@ -50,7 +50,7 @@ - -- - -- The @tmpFlie@ will be file in the given directory, e.g. - -- @src/sdist.342@. --withTempFile :: (MonadIO m, MonadCatch m) => -+withTempFile :: (MonadIO m, MonadMask m) => - FilePath -- ^ Temp dir to create the file in - -> String -- ^ File name template. See 'openTempFile'. - -> (FilePath -> Handle -> m a) -- ^ Callback that can use the file -@@ -70,7 +70,7 @@ - -- - -- The @tmpDir@ will be a new subdirectory of the given directory, e.g. - -- @src/sdist.342@. --withTempDirectory :: (MonadCatch m, MonadIO m) => -+withTempDirectory :: (MonadMask m, MonadIO m) => - FilePath -- ^ Temp directory to create the directory in - -> String -- ^ Directory name template. See 'openTempFile'. - -> (FilePath -> m a) -- ^ Callback that can use the directory diff --git a/patching/patches/th-desugar-1.4.2.patch b/patching/patches/th-desugar-1.4.2.patch deleted file mode 100644 index 1d51c63b..00000000 --- a/patching/patches/th-desugar-1.4.2.patch +++ /dev/null @@ -1,20 +0,0 @@ -diff -ruN orig/Test/Run.hs new/Test/Run.hs ---- orig/Test/Run.hs 2014-08-19 09:57:25.537902164 +0300 -+++ new/Test/Run.hs 2014-08-19 09:57:25.000000000 +0300 -@@ -27,6 +27,7 @@ - import Language.Haskell.TH.Desugar.Expand - import Language.Haskell.TH.Desugar.Sweeten - import Language.Haskell.TH -+import Language.Haskell.TH.Syntax (qRunIO) - - import Control.Monad - -@@ -121,7 +122,7 @@ - case (resK, lhs) of - (DStarK, [DVarT _]) -> [| True |] - _ -> do -- runIO $ do -+ qRunIO $ do - putStrLn "Failed bug8884 test:" - putStrLn $ show dinfo - [| False |] ) diff --git a/patching/patches/threepenny-gui-0.4.1.0.patch b/patching/patches/threepenny-gui-0.4.1.0.patch deleted file mode 100644 index db1b09ef..00000000 --- a/patching/patches/threepenny-gui-0.4.1.0.patch +++ /dev/null @@ -1,47 +0,0 @@ -diff -ru orig/src/Graphics/UI/Threepenny/Internal/Driver.hs new/src/Graphics/UI/Threepenny/Internal/Driver.hs ---- orig/src/Graphics/UI/Threepenny/Internal/Driver.hs 2014-03-13 10:29:00.049732639 +0200 -+++ new/src/Graphics/UI/Threepenny/Internal/Driver.hs 2014-03-13 10:28:59.000000000 +0200 -@@ -248,7 +248,7 @@ - signal Session{..} = do - input <- getParam "signal" - let err = error $ "Unable to parse " ++ show input -- case JSON.decode . LBS.fromStrict =<< input of -+ case JSON.decode . LBS.fromChunks . return =<< input of - Just signal -> liftIO $ writeChan sSignals signal - Nothing -> err - -diff -ru orig/src/Graphics/UI/Threepenny/Internal/Types.hs new/src/Graphics/UI/Threepenny/Internal/Types.hs ---- orig/src/Graphics/UI/Threepenny/Internal/Types.hs 2014-03-13 10:29:00.049732639 +0200 -+++ new/src/Graphics/UI/Threepenny/Internal/Types.hs 2014-03-13 10:28:59.000000000 +0200 -@@ -17,6 +17,7 @@ - import Data.Map (Map) - import Data.String (fromString) - import Data.Time -+import Data.Text.Encoding (encodeUtf8, decodeUtf8) - - import Network.URI - import Data.Data -@@ -62,9 +63,9 @@ - - -- Marshalling ElementId - instance ToJSON ElementId where -- toJSON (ElementId o) = toJSON o -+ toJSON (ElementId o) = toJSON $ decodeUtf8 o - instance FromJSON ElementId where -- parseJSON (Object v) = ElementId <$> v .: "Element" -+ parseJSON (Object v) = (ElementId . encodeUtf8) <$> v .: "Element" - parseJSON _ = mzero - - -diff -ru orig/threepenny-gui.cabal new/threepenny-gui.cabal ---- orig/threepenny-gui.cabal 2014-03-13 10:29:00.057732639 +0200 -+++ new/threepenny-gui.cabal 2014-03-13 10:28:59.000000000 +0200 -@@ -92,7 +92,7 @@ - cpp-options: -DREBUG - ghc-options: -O2 - build-depends: base >= 4 && < 5 -- ,aeson == 0.6.* -+ ,aeson >= 0.6 - ,attoparsec-enumerator == 0.3.* - ,bytestring >= 0.9.2 && < 0.11 - ,containers >= 0.4.2 && < 0.6 diff --git a/patching/patches/transformers-compat-0.3.3.4.patch b/patching/patches/transformers-compat-0.3.3.4.patch deleted file mode 100644 index 159ff558..00000000 --- a/patching/patches/transformers-compat-0.3.3.4.patch +++ /dev/null @@ -1,50 +0,0 @@ -Only in orig: 0.2 -diff -ru orig/transformers-compat.cabal new/transformers-compat.cabal ---- orig/transformers-compat.cabal 2014-06-20 06:30:48.534077053 +0300 -+++ new/transformers-compat.cabal 2014-06-20 06:30:48.000000000 +0300 -@@ -38,17 +38,6 @@ - type: git - location: git://github.com/ekmett/transformers-compat.git - --flag two -- default: False -- description: Use transformers 0.2. This must be selected manually and should -- probably only be used on older GHCs around 7.0.x. -- manual: True -- --flag three -- default: False -- manual: True -- description: Use transformers 0.3. This should toggle on/off automatically. -- - library - build-depends: - base >= 4.3 && < 5 -@@ -56,24 +45,10 @@ - other-modules: - Paths_transformers_compat - -- if flag(three) -- hs-source-dirs: 0.3 -- build-depends: transformers >= 0.3 && < 0.4 -- else -- if flag(two) -- hs-source-dirs: 0.2 0.3 -- build-depends: transformers >= 0.2 && < 0.3 -- else -- build-depends: transformers >= 0.4.1 && < 0.5 -- -- if flag(two) -- exposed-modules: -- Control.Applicative.Backwards -- Control.Applicative.Lift -- Data.Functor.Reverse -+ hs-source-dirs: 0.3 -+ build-depends: transformers >= 0.3 && < 0.4 - -- if flag(two) || flag(three) -- exposed-modules: -+ exposed-modules: - Control.Monad.Trans.Except - Control.Monad.Signatures - Data.Functor.Classes diff --git a/patching/patches/uniqueid-0.1.1.patch b/patching/patches/uniqueid-0.1.1.patch deleted file mode 100644 index 633095cb..00000000 --- a/patching/patches/uniqueid-0.1.1.patch +++ /dev/null @@ -1,100 +0,0 @@ -diff -ru orig/Data/Unique/Id.hs new/Data/Unique/Id.hs ---- orig/Data/Unique/Id.hs 2014-04-14 09:11:35.637516354 +0300 -+++ new/Data/Unique/Id.hs 2014-04-14 09:11:35.000000000 +0300 -@@ -1,3 +1,4 @@ -+{-# LANGUAGE CPP #-} - {-# LANGUAGE MagicHash #-} - - -- | This module provides splittable supplies for unique identifiers. -@@ -13,6 +14,86 @@ - - ) where - -+#if MIN_VERSION_base(4,7,0) -+ -+import GHC.Exts -+import GHC.IO ( unsafeDupableInterleaveIO ) -+ -+import Data.IORef -+import System.IO.Unsafe ( unsafePerformIO ) -+ -+-- | Unique identifiers are of type 'Id' and can be hashed to an 'Int' -+-- usning the function 'hashedId'. -+newtype Id = Id { hashedId :: Int } -+ -+-- | Supplies for unique identifiers are of type 'IdSupply' and can be -+-- split into two new supplies or yield a unique identifier. -+data IdSupply = IdSupply Int# IdSupply IdSupply -+ -+-- | Generates a new supply of unique identifiers. The given character -+-- is prepended to generated numbers. -+initIdSupply :: Char -> IO IdSupply -+initIdSupply (C# c) = -+ case uncheckedIShiftL# (ord# c) (unboxedInt 24) of -+ mask -> -+ let mkSupply = -+ unsafeDupableInterleaveIO ( -+ nextInt >>= \ (I# u) -> -+ mkSupply >>= \ l -> -+ mkSupply >>= \ r -> -+ return (IdSupply (word2Int# (or# (int2Word# mask) (int2Word# u))) l r)) -+ in mkSupply -+ -+-- | Splits a supply of unique identifiers to yield two of them. -+splitIdSupply :: IdSupply -> (IdSupply,IdSupply) -+splitIdSupply (IdSupply _ l r) = (l,r) -+ -+-- | Splits a supply of unique identifiers to yield an infinite list of them. -+splitIdSupplyL :: IdSupply -> [IdSupply] -+splitIdSupplyL ids = ids1 : splitIdSupplyL ids2 -+ where -+ (ids1, ids2) = splitIdSupply ids -+ -+-- | Yields the unique identifier from a supply. -+idFromSupply :: IdSupply -> Id -+idFromSupply (IdSupply n _ _) = Id (I# n) -+ -+instance Eq Id where Id (I# x) == Id (I# y) = I# (x ==# y) /= 0 -+ -+instance Ord Id -+ where -+ Id (I# x) < Id (I# y) = I# (x <# y) /= 0 -+ Id (I# x) <= Id (I# y) = I# (x <=# y) /= 0 -+ -+ compare (Id (I# x)) (Id (I# y)) = -+ if I# (x ==# y) /= 0 then EQ else if I# (x <# y) /= 0 then LT else GT -+ -+instance Show Id -+ where -+ showsPrec _ i s = case unpackId i of (c,n) -> c:show n++s -+ -+ -+ -+ -+unboxedInt :: Int -> Int# -+unboxedInt (I# x) = x -+ -+global :: IORef Int -+global = unsafePerformIO (newIORef 0) -+ -+nextInt :: IO Int -+nextInt = do -+ n <- readIORef global -+ writeIORef global (succ n) -+ return n -+ -+unpackId :: Id -> (Char,Int) -+unpackId (Id (I# i)) = -+ let tag = C# (chr# (uncheckedIShiftRL# i (unboxedInt 24))) -+ num = I# (word2Int# (and# (int2Word# i) -+ (int2Word# (unboxedInt 16777215)))) -+ in (tag, num) -+#else - import GHC.Exts - import GHC.IOBase ( unsafeDupableInterleaveIO ) - -@@ -90,3 +171,4 @@ - num = I# (word2Int# (and# (int2Word# i) - (int2Word# (unboxedInt 16777215)))) - in (tag, num) -+#endif diff --git a/patching/patches/websockets-0.8.2.0.patch b/patching/patches/websockets-0.8.2.0.patch deleted file mode 100644 index 6e209777..00000000 --- a/patching/patches/websockets-0.8.2.0.patch +++ /dev/null @@ -1,21 +0,0 @@ -diff -ru orig/websockets.cabal new/websockets.cabal ---- orig/websockets.cabal 2014-04-03 08:32:53.818374925 +0300 -+++ new/websockets.cabal 2014-04-03 08:32:53.000000000 +0300 -@@ -69,7 +69,7 @@ - binary >= 0.5 && < 0.8, - blaze-builder >= 0.3 && < 0.4, - bytestring >= 0.9 && < 0.11, -- case-insensitive >= 0.3 && < 1.2, -+ case-insensitive >= 0.3 && < 1.3, - containers >= 0.3 && < 0.6, - io-streams >= 1.1 && < 1.2, - mtl >= 2.0 && < 2.2, -@@ -105,7 +105,7 @@ - binary >= 0.5 && < 0.8, - blaze-builder >= 0.3 && < 0.4, - bytestring >= 0.9 && < 0.11, -- case-insensitive >= 0.3 && < 1.2, -+ case-insensitive >= 0.3 && < 1.3, - containers >= 0.3 && < 0.6, - io-streams >= 1.1 && < 1.2, - mtl >= 2.0 && < 2.2, diff --git a/patching/patches/yesod-auth-fb-1.6.1.patch b/patching/patches/yesod-auth-fb-1.6.1.patch deleted file mode 100644 index c1f87860..00000000 --- a/patching/patches/yesod-auth-fb-1.6.1.patch +++ /dev/null @@ -1,77 +0,0 @@ -diff -ru orig/demo/clientside.hs new/demo/clientside.hs ---- orig/demo/clientside.hs 2014-03-30 12:27:40.941431437 +0300 -+++ new/demo/clientside.hs 2014-03-30 12:27:40.000000000 +0300 -@@ -27,7 +27,7 @@ - - - instance Yesod Test where -- approot = ApprootStatic "http://dev.whonodes.org:3000" -+ approot = FIXME -- FIXME: Put your approot here - - instance RenderMessage Test FormMessage where - renderMessage _ _ = englishFormMessage -diff -ru orig/src/Yesod/Auth/Facebook/ClientSide.hs new/src/Yesod/Auth/Facebook/ClientSide.hs ---- orig/src/Yesod/Auth/Facebook/ClientSide.hs 2014-03-30 12:27:40.941431437 +0300 -+++ new/src/Yesod/Auth/Facebook/ClientSide.hs 2014-03-30 12:27:40.000000000 +0300 -@@ -364,7 +364,7 @@ - AuthPlugin "fbcs" dispatch login - where - dispatch :: YesodAuthFbClientSide site => -- Text -> [Text] -> HandlerT Auth (HandlerT site IO) () -+ Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent - -- Login route used when successfully logging in. Called via - -- AJAX by JavaScript code on 'facebookJSSDK'. - dispatch "GET" ["login"] = do -@@ -372,7 +372,7 @@ - when (redirectToReferer y) (lift setUltDestReferer) - etoken <- lift getUserAccessTokenFromFbCookie - case etoken of -- Right token -> lift $ setCreds True (createCreds token) -+ Right token -> lift $ setCredsRedirect (createCreds token) - Left msg -> fail msg - - -- Login routes used to forcefully require the user to login. -@@ -406,7 +406,7 @@ - token <- lift $ - YF.runYesodFbT $ - FB.getUserAccessTokenStep2 proceedUrl query' -- lift $ setCreds True (createCreds token) -+ lift $ setCredsRedirect (createCreds token) - - -- Everything else gives 404 - dispatch _ _ = notFound -diff -ru orig/src/Yesod/Auth/Facebook/ServerSide.hs new/src/Yesod/Auth/Facebook/ServerSide.hs ---- orig/src/Yesod/Auth/Facebook/ServerSide.hs 2014-03-30 12:27:40.941431437 +0300 -+++ new/src/Yesod/Auth/Facebook/ServerSide.hs 2014-03-30 12:27:40.000000000 +0300 -@@ -56,7 +56,7 @@ - proceedR = PluginR "fb" ["proceed"] - - dispatch :: (YesodAuth site, YF.YesodFacebook site) => -- Text -> [Text] -> HandlerT Auth (HandlerT site IO) () -+ Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent - -- Redirect the user to Facebook. - dispatch "GET" ["login"] = do - ur <- getUrlRender -@@ -73,7 +73,7 @@ - lift $ do - token <- YF.runYesodFbT $ FB.getUserAccessTokenStep2 proceedUrl query' - setUserAccessToken token -- setCreds True (createCreds token) -+ setCredsRedirect (createCreds token) - -- Logout the user from our site and from Facebook. - dispatch "GET" ["logout"] = do - y <- lift getYesod -diff -ru orig/yesod-auth-fb.cabal new/yesod-auth-fb.cabal ---- orig/yesod-auth-fb.cabal 2014-03-30 12:27:40.945431436 +0300 -+++ new/yesod-auth-fb.cabal 2014-03-30 12:27:40.000000000 +0300 -@@ -43,8 +43,9 @@ - Build-depends: base >= 4.3 && < 5 - , lifted-base >= 0.1 && < 0.3 - , yesod-core == 1.2.* -- , yesod-auth == 1.2.* -+ , yesod-auth == 1.3.* - , hamlet -+ , shakespeare - , shakespeare-js >= 1.0.2 - , wai - , http-conduit >= 1.9 diff --git a/patching/patches/yesod-auth-oauth-1.2.0.patch b/patching/patches/yesod-auth-oauth-1.2.0.patch deleted file mode 100644 index 6289e36b..00000000 --- a/patching/patches/yesod-auth-oauth-1.2.0.patch +++ /dev/null @@ -1,26 +0,0 @@ -diff -ru orig/Yesod/Auth/OAuth.hs new/Yesod/Auth/OAuth.hs ---- orig/Yesod/Auth/OAuth.hs 2014-03-30 12:34:43.941422434 +0300 -+++ new/Yesod/Auth/OAuth.hs 2014-03-30 12:34:43.000000000 +0300 -@@ -72,7 +72,7 @@ - master <- getYesod - accTok <- getAccessToken oauth reqTok (authHttpManager master) - creds <- liftIO $ mkCreds accTok -- setCreds True creds -+ setCredsRedirect creds - dispatch _ _ = notFound - login tm = do - render <- getUrlRender -diff -ru orig/yesod-auth-oauth.cabal new/yesod-auth-oauth.cabal ---- orig/yesod-auth-oauth.cabal 2014-03-30 12:34:43.941422434 +0300 -+++ new/yesod-auth-oauth.cabal 2014-03-30 12:34:43.000000000 +0300 -@@ -23,8 +23,8 @@ - build-depends: authenticate-oauth >= 1.4 && < 1.5 - , bytestring >= 0.9.1.4 - , yesod-core >= 1.2 && < 1.3 -- , yesod-auth >= 1.2 && < 1.3 -- , text >= 0.7 && < 0.12 -+ , yesod-auth >= 1.3 && < 1.4 -+ , text >= 0.7 && < 1.2 - , yesod-form >= 1.3 && < 1.4 - , transformers >= 0.2.2 && < 0.4 - , lifted-base >= 0.2 && < 0.3