diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,3 @@ #!/usr/bin/env runhaskell import Distribution.Simple -main = defaultMainWithHooks defaultUserHooks +main = defaultMainWithHooks simpleUserHooks diff --git a/happstack-state.cabal b/happstack-state.cabal --- a/happstack-state.cabal +++ b/happstack-state.cabal @@ -1,5 +1,5 @@ Name: happstack-state -Version: 0.4.1 +Version: 0.5.0 Synopsis: Event-based distributed state. Description: Unplug your machine and restart and have your app recover to exactly where it left off. Happstack-State spares you the need to deal with all the marshalling, consistency, and configuration headache that you would have if you used an external DBMS for this purpose. Its component model makes it easy to compose big applications from smaller reliable parts. Use event subscription to trigger IO actions and support comet-style or irc-bot applications. License: BSD3 @@ -37,6 +37,7 @@ Happstack.State.ComponentTH Happstack.State.ComponentSystem if flag(tests) + Build-Depends: QuickCheck >= 2 && <3, HUnit, network Exposed-modules: Happstack.State.Tests Happstack.State.Tests.Helpers @@ -60,8 +61,8 @@ extensible-exceptions, filepath, hslogger >= 1.0.2, - happstack-util >= 0.4.1 && < 0.5, - happstack-data >= 0.4.1 && < 0.5, + happstack-util >= 0.5 && < 0.6, + happstack-data >= 0.5 && < 0.6, mtl, old-time, random, @@ -81,8 +82,6 @@ Build-Depends: base >= 4 && < 5, syb else Build-Depends: base < 4 - if flag(tests) - Build-Depends: QuickCheck < 2, HUnit hs-source-dirs: src if flag(tests) diff --git a/src/Happstack/State/Checkpoint.hs b/src/Happstack/State/Checkpoint.hs --- a/src/Happstack/State/Checkpoint.hs +++ b/src/Happstack/State/Checkpoint.hs @@ -9,7 +9,6 @@ import Happstack.Data.Serialize import Happstack.Data.SerializeTH import Happstack.State.Transaction -import Happstack.State.ComponentSystem import Data.Typeable import Data.Maybe @@ -17,8 +16,6 @@ import Control.Monad import Control.Exception as E import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.Map as M -import System.IO import qualified Data.Map as M import System.Log.Logger diff --git a/src/Happstack/State/ComponentSystem.hs b/src/Happstack/State/ComponentSystem.hs --- a/src/Happstack/State/ComponentSystem.hs +++ b/src/Happstack/State/ComponentSystem.hs @@ -3,7 +3,6 @@ module Happstack.State.ComponentSystem where import Happstack.Data.Serialize -import Happstack.Data.Proxy import Happstack.State.Types import Data.Typeable diff --git a/src/Happstack/State/Control.hs b/src/Happstack/State/Control.hs --- a/src/Happstack/State/Control.hs +++ b/src/Happstack/State/Control.hs @@ -13,10 +13,7 @@ import System.Log.Handler.Simple import System.Log.Handler.Syslog -import Control.Monad -import Data.List import Data.Char -import Data.Maybe import System.Environment import System.IO import System.Exit diff --git a/src/Happstack/State/Monad.hs b/src/Happstack/State/Monad.hs --- a/src/Happstack/State/Monad.hs +++ b/src/Happstack/State/Monad.hs @@ -9,7 +9,6 @@ import Control.Monad.State import Control.Monad.Reader -import Control.Monad instance (Monad m) => Monad (Ev m) where return x = Ev $ \_ -> return x diff --git a/src/Happstack/State/Saver/Impl/File.hs b/src/Happstack/State/Saver/Impl/File.hs --- a/src/Happstack/State/Saver/Impl/File.hs +++ b/src/Happstack/State/Saver/Impl/File.hs @@ -16,7 +16,6 @@ import qualified Data.ByteString as B import System.Directory ( createDirectoryIfMissing, removeFile, renameFile, doesFileExist ) import System.IO -import qualified System.IO.Error as SE import System.Random ( randomIO ) import System.Log.Logger import Text.Printf diff --git a/src/Happstack/State/Transaction.hs b/src/Happstack/State/Transaction.hs --- a/src/Happstack/State/Transaction.hs +++ b/src/Happstack/State/Transaction.hs @@ -22,7 +22,6 @@ import Happstack.Data.Serialize import Happstack.Data.SerializeTH import Happstack.State.Types -import Happstack.Util.Common (Seconds) import Data.Dynamic import GHC.Base diff --git a/src/Happstack/State/TxControl.hs b/src/Happstack/State/TxControl.hs --- a/src/Happstack/State/TxControl.hs +++ b/src/Happstack/State/TxControl.hs @@ -7,7 +7,6 @@ ) where import System.Log.Logger -import System.IO import Control.Monad import Control.Exception import Control.Concurrent diff --git a/src/Happstack/State/Types.hs b/src/Happstack/State/Types.hs --- a/src/Happstack/State/Types.hs +++ b/src/Happstack/State/Types.hs @@ -15,7 +15,6 @@ import Control.Monad.State import Control.Monad.Reader -import Control.Monad.Trans import Data.Generics -- Monad things diff --git a/src/Happstack/State/Util.hs b/src/Happstack/State/Util.hs --- a/src/Happstack/State/Util.hs +++ b/src/Happstack/State/Util.hs @@ -7,7 +7,6 @@ ) where import Control.Concurrent.STM -import Control.Monad.State import System.Random import Happstack.State.Monad diff --git a/tests/Happstack/State/Tests/CheckpointProperties.hs b/tests/Happstack/State/Tests/CheckpointProperties.hs --- a/tests/Happstack/State/Tests/CheckpointProperties.hs +++ b/tests/Happstack/State/Tests/CheckpointProperties.hs @@ -2,7 +2,6 @@ module Happstack.State.Tests.CheckpointProperties ( testCongestedCheckpoint , congestedCheckpoint - , checkCheckpointProperties , checkpointProperties , runRestoreCongestionKnownFailures ) where @@ -22,7 +21,6 @@ import Text.Printf import Test.QuickCheck -import Test.QuickCheck.Batch import Test.HUnit (Test(..),(~:), assertBool, assertFailure) -------------------------------------------------------------- @@ -179,7 +177,7 @@ forkIO $ createCheckpoint ctl `finally` putMVar mv () takeMVar mv replicateM_ (length values) (waitQSem sem) - +{- checkCheckpointProperties :: IO () checkCheckpointProperties = tryTests ("runRestore") options [run (prop_runRestoreId saver) @@ -187,20 +185,20 @@ ,run (prop_runRestoreMultipleCheckpoint saver) ,run (prop_runRestoreAsync saver) ,run (prop_runRestoreCongestion saver)] - where options = defOpt{length_of_tests=5} + where args = stdArgs {maxSize=5} saver = withQueueSaver withMemorySaver - +-} checkpointProperties :: Test checkpointProperties = "checkpointProperties" ~: - [ "prop_runRestoreId" ~: qccheck config (prop_runRestoreId saver) - , "prop_runRestoreCheckpoint" ~: qccheck config (prop_runRestoreCheckpoint saver) - , "prop_runRestoreMultipleCheckpoint" ~: qccheck config (prop_runRestoreMultipleCheckpoint saver) - , "prop_runRestoreAsync" ~: qccheck config (prop_runRestoreAsync saver) - , "prop_runRestoreCongestion" ~: qccheck config (prop_runRestoreCongestion saver) + [ "prop_runRestoreId" ~: qccheck args (prop_runRestoreId saver) + , "prop_runRestoreCheckpoint" ~: qccheck args (prop_runRestoreCheckpoint saver) + , "prop_runRestoreMultipleCheckpoint" ~: qccheck args (prop_runRestoreMultipleCheckpoint saver) + , "prop_runRestoreAsync" ~: qccheck args (prop_runRestoreAsync saver) + , "prop_runRestoreCongestion" ~: qccheck args (prop_runRestoreCongestion saver) ] where - config = defaultConfig { configMaxTest = 100 } + args = stdArgs { maxSize = 100 } saver = withQueueSaver withMemorySaver diff --git a/tests/Happstack/State/Tests/Helpers.hs b/tests/Happstack/State/Tests/Helpers.hs --- a/tests/Happstack/State/Tests/Helpers.hs +++ b/tests/Happstack/State/Tests/Helpers.hs @@ -12,23 +12,16 @@ import Control.Exception import Control.Concurrent -import Test.QuickCheck -import Test.QuickCheck.Batch +import Test.QuickCheck (Arbitrary(arbitrary), choose) import Text.Printf -instance Arbitrary Char where - arbitrary = choose ('a','z') - coarbitrary = undefined - instance (Arbitrary a, Num a) => Arbitrary (Abs a) where arbitrary = liftM (Abs . abs) arbitrary - coarbitrary = undefined instance (Arbitrary a) => Arbitrary (NonEmpty a) where arbitrary = do x <- arbitrary xs <- arbitrary return $ NonEmpty (x:xs) - coarbitrary = undefined data Abs a = Abs a instance (Show a) => Show (Abs a) where @@ -88,7 +81,7 @@ , ("File", withFileSaver) , ("Queue File", \action -> withFileSaver (action . Queue)) ] - +{- tryTests :: String -> TestOptions -> [TestOptions -> IO TestResult] -> IO () tryTests name opt tests = do printf "%25s : " name @@ -106,3 +99,4 @@ putStrLn (" ** " ++ show exp) exitWith (ExitFailure 1) putChar '\n' +-} diff --git a/tests/Happstack/State/Tests/SaverProperties.hs b/tests/Happstack/State/Tests/SaverProperties.hs --- a/tests/Happstack/State/Tests/SaverProperties.hs +++ b/tests/Happstack/State/Tests/SaverProperties.hs @@ -1,44 +1,43 @@ module Happstack.State.Tests.SaverProperties - ( checkSaverProperties - , saverProperties + ( saverProperties ) where - +import Control.Monad +import Control.Exception +import Control.Concurrent +import Data.Char (isAlphaNum) +import Data.List import Happstack.State.Saver import Happstack.State.Saver.Impl.Memory import Happstack.State.Tests.Helpers -import Happstack.Util.Testing (qctest, qcrun) - +import Happstack.Util.Testing (qctest, qccheck) import System.Directory import System.Random import System.FilePath import System.IO.Unsafe -import Control.Monad -import Control.Exception -import Control.Concurrent -import Data.List -import Test.QuickCheck -import Test.QuickCheck.Batch -import Test.HUnit (Test(TestCase),(~:), assertFailure) +import Test.QuickCheck (Args(maxSize), Property, (==>), stdArgs) +import Test.HUnit (Test(TestCase),(~:)) -------------------------------------------------------------- -- Tests -------------------------------------------------------------- -- read (write values) == values -prop_getSetId withSaver key cutoff values - = not (null key) ==> - cutoff > 0 ==> +prop_getSetId :: ((Saver -> IO Bool) -> IO Bool) -> {- String -> -} Int -> [Int] -> Property +prop_getSetId withSaver {- (NonEmpty key) -} cutoff values + = (abs cutoff) > 0 ==> ioProperty $ withSaver $ \saver -> - do writer <- createWriter saver key cutoff + do writer <- createWriter saver key (abs cutoff) forM_ values $ \value -> writerAdd writer (value::Int) $ return () writerClose writer - reader <- createReader saver key cutoff + reader <- createReader saver key (abs cutoff) out <- readerGetUncut reader return $ values == out + where + key = "key" -- not sure if randomly generating the key is useful. But it was causing trouble because it contain ~ / and other meaningful characters -prop_seqReadWrite withSaver (NonEmpty key) (Abs cutoff) valss +prop_seqReadWrite withSaver {-(NonEmpty key) -} (Abs cutoff) valss = ioProperty $ withSaver $ \saver -> do writer <- createWriter saver key cutoff forM_ valss $ \vals -> do forM_ vals $ \val -> writerAdd writer (val::Int) $ return () @@ -48,8 +47,10 @@ reader <- createReader saver key cutoff (out,newCut) <- readerGet reader return $ out == concat valss && newCut == length valss + 1 + where + key = "key" -prop_cutDrop withSaver (NonEmpty key) (Abs cutoff) a b +prop_cutDrop withSaver {- (NonEmpty key) -} (Abs cutoff) a b = ioProperty $ withSaver $ \saver -> do writer <- createWriter saver key cutoff forM_ a $ \val -> writerAdd writer (val::Int) $ return () @@ -60,8 +61,10 @@ reader <- createReader saver key newCut (out,_) <- readerGet reader return $ b `isSuffixOf` out + where + key = "key" -prop_atomic withSaver (NonEmpty key) (Abs cutoff) value +prop_atomic withSaver {- (NonEmpty key) -} (Abs cutoff) value = ioProperty $ withSaver $ \saver -> do writer <- createWriter saver key cutoff writerAtomicReplace writer (value::Int) @@ -71,24 +74,26 @@ out <- readerGetUncut reader readerClose reader return $ out == [value] - + where + key = "key" +{- checkSaverProperties :: IO () checkSaverProperties = forEachSaver_ $ \name withSaver -> - tryTests (name ++ " saver") options [run (prop_getSetId withSaver) + tryTests (name ++ " saver") args [run (prop_getSetId withSaver) ,run (prop_seqReadWrite withSaver) ,run (prop_cutDrop withSaver) ,run (prop_atomic withSaver)] - where options = defOpt{length_of_tests=5} - + where args = stdArgs{maxSize=5} +-} saverProperties :: Test saverProperties = "saverProperties" ~: ((forEachSaver $ \name withSaver -> name ~: - [ "prop_getSetId" ~: qcrun (prop_getSetId withSaver) options - , "prop_seqReadWrite" ~: qcrun (prop_seqReadWrite withSaver) options - , "prop_cutDrop" ~: qcrun (prop_cutDrop withSaver) options - , "prop_atomic" ~: qcrun (prop_atomic withSaver) options + [ "prop_getSetId" ~: qccheck args (prop_getSetId withSaver) + , "prop_seqReadWrite" ~: qccheck args (prop_seqReadWrite withSaver) + , "prop_cutDrop" ~: qccheck args (prop_cutDrop withSaver) + , "prop_atomic" ~: qccheck args (prop_atomic withSaver) ])) - where options = defOpt{length_of_tests=5} + where args = stdArgs{maxSize=5}