summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authork_bx <>2018-12-06 10:46:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-12-06 10:46:00 (GMT)
commit5d80e7f6e25b1c073cbfb6cc645bfe05ea5e1626 (patch)
tree28185cfc9d3134700980bcbaa0026c3477128b96
parentb167ff2b276706169950a25c7908904fc2ec5507 (diff)
version 0.10.10HEAD0.10.10master
-rw-r--r--CHANGELOG4
-rw-r--r--benchmark/Benchmark.hs52
-rw-r--r--hedis.cabal6
-rw-r--r--test/Test.hs148
4 files changed, 142 insertions, 68 deletions
diff --git a/CHANGELOG b/CHANGELOG
index f67c317..dd1a2a3 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,5 +1,9 @@
# Changelog for Hedis
+## 0.10.10
+
+* Only disable warnings for GHC 8.6, fix build
+
## 0.10.9
* Remove deprecation warnings
diff --git a/benchmark/Benchmark.hs b/benchmark/Benchmark.hs
index 31d3a19..ecc0583 100644
--- a/benchmark/Benchmark.hs
+++ b/benchmark/Benchmark.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, LambdaCase #-}
module Main where
@@ -22,8 +22,10 @@ main = do
conn <- connect defaultConnectInfo
runRedis conn $ do
_ <- flushall
- Right _ <- mset [ ("k1","v1"), ("k2","v2"), ("k3","v3")
- , ("k4","v4"), ("k5","v5") ]
+ mset [ ("k1","v1"), ("k2","v2"), ("k3","v3")
+ , ("k4","v4"), ("k5","v5") ] >>= \case
+ Left _ -> error "error"
+ _ -> return ()
return ()
@@ -55,38 +57,56 @@ main = do
-- Benchmarks
--
timeAction "ping" 1 $ do
- Right Pong <- ping
+ ping >>= \case
+ Right Pong -> return ()
+ _ -> error "error"
return ()
timeAction "get" 1 $ do
- Right Nothing <- get "key"
+ get "key" >>= \case
+ Right Nothing -> return ()
+ _ -> error "error"
return ()
timeAction "mget" 1 $ do
- Right vs <- mget ["k1","k2","k3","k4","k5"]
- let expected = map Just ["v1","v2","v3","v4","v5"]
- True <- return $ vs == expected
- return ()
+ mget ["k1","k2","k3","k4","k5"] >>= \case
+ Right vs -> do
+ let expected = map Just ["v1","v2","v3","v4","v5"]
+ case vs == expected of
+ True -> return ()
+ _ -> error "error"
+ return ()
+ _ -> error "error"
timeAction "ping (pipelined)" 100 $ do
pongs <- replicateM 100 ping
let expected = replicate 100 (Right Pong)
- True <- return $ pongs == expected
+ case pongs == expected of
+ True -> return ()
+ _ -> error "error"
return ()
timeAction "multiExec get 1" 1 $ do
- TxSuccess _ <- multiExec $ get "foo"
+ multiExec (get "foo") >>= \case
+ TxSuccess _ -> return ()
+ _ -> error "error"
return ()
timeAction "multiExec get 50" 50 $ do
- TxSuccess 50 <- multiExec $ do
- rs <- replicateM 50 (get "foo")
- return $ fmap length (sequence rs)
+ res <- multiExec $ do
+ rs <- replicateM 50 (get "foo")
+ return $ fmap length (sequence rs)
+ case res of
+ TxSuccess 50 -> return ()
+ _ -> error "error"
return ()
timeAction "multiExec get 1000" 1000 $ do
- TxSuccess 1000 <- multiExec $ do
+ res <- multiExec $ do
rs <- replicateM 1000 (get "foo")
return $ fmap length (sequence rs)
+ case res of
+ TxSuccess 1000 -> return ()
+ _ -> error "error"
return ()
- \ No newline at end of file
+
diff --git a/hedis.cabal b/hedis.cabal
index 9bb065f..1a300b0 100644
--- a/hedis.cabal
+++ b/hedis.cabal
@@ -1,5 +1,5 @@
name: hedis
-version: 0.10.9
+version: 0.10.10
synopsis:
Client library for the Redis datastore: supports full command set,
pipelining.
@@ -59,7 +59,9 @@ flag dev
library
hs-source-dirs: src
- ghc-options: -Wall -fwarn-tabs -Wno-warnings-deprecations
+ ghc-options: -Wall -fwarn-tabs
+ if impl(ghc >= 8.6.0)
+ ghc-options: -Wno-warnings-deprecations
if flag(dev)
ghc-options: -Werror
if flag(dev)
diff --git a/test/Test.hs b/test/Test.hs
index d305123..d9c4cca 100644
--- a/test/Test.hs
+++ b/test/Test.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, OverloadedStrings, RecordWildCards #-}
+{-# LANGUAGE CPP, OverloadedStrings, RecordWildCards, LambdaCase #-}
module Main (main) where
#if __GLASGOW_HASKELL__ < 710
@@ -84,7 +84,9 @@ testConstantSpacePipelining = testCase "constant-space pipelining" $ do
testForceErrorReply :: Test
testForceErrorReply = testCase "force error reply" $ do
- Right _ <- set "key" "value"
+ set "key" "value" >>= \case
+ Left _ -> error "impossible"
+ _ -> return ()
-- key is not a hash -> wrong kind of value
reply <- hkeys "key"
assert $ case reply of
@@ -137,17 +139,23 @@ testKeys = testCase "keys" $ do
select 13 >>=? Ok
expire "key" 1 >>=? True
pexpire "key" 1000 >>=? True
- Right t <- ttl "key"
- assert $ t `elem` [0..1]
- Right pt <- pttl "key"
- assert $ pt `elem` [990..1000]
- persist "key" >>=? True
- Right s <- dump "key"
- restore "key'" 0 s >>=? Ok
- rename "key" "key'" >>=? Ok
- renamenx "key'" "key" >>=? True
- del ["key"] >>=? 1
- select 0 >>=? Ok
+ ttl "key" >>= \case
+ Left _ -> error "error"
+ Right t -> do
+ assert $ t `elem` [0..1]
+ pttl "key" >>= \case
+ Left _ -> error "error"
+ Right pt -> do
+ assert $ pt `elem` [990..1000]
+ persist "key" >>=? True
+ dump "key" >>= \case
+ Left _ -> error "impossible"
+ Right s -> do
+ restore "key'" 0 s >>=? Ok
+ rename "key" "key'" >>=? Ok
+ renamenx "key'" "key" >>=? True
+ del ["key"] >>=? 1
+ select 0 >>=? Ok
testExpireAt :: Test
testExpireAt = testCase "expireat" $ do
@@ -162,14 +170,16 @@ testSort = testCase "sort" $ do
lpush "ids" ["1","2","3"] >>=? 3
sort "ids" defaultSortOpts >>=? ["1","2","3"]
sortStore "ids" "anotherKey" defaultSortOpts >>=? 3
- Right _ <- mset
+ mset
[("weight_1","1")
,("weight_2","2")
,("weight_3","3")
,("object_1","foo")
,("object_2","bar")
,("object_3","baz")
- ]
+ ] >>= \case
+ Left _ -> error "error"
+ _ -> return ()
let opts = defaultSortOpts { sortOrder = Desc, sortAlpha = True
, sortLimit = (1,2)
, sortBy = Just "weight_*"
@@ -196,7 +206,9 @@ testObject :: Test
testObject = testCase "object" $ do
set "key" "value" >>=? Ok
objectRefcount "key" >>=? 1
- Right _ <- objectEncoding "key"
+ objectEncoding "key" >>= \case
+ Left _ -> error "error"
+ _ -> return ()
objectIdletime "key" >>=? 0
------------------------------------------------------------------------------
@@ -358,8 +370,12 @@ testZSets = testCase "sorted sets" $ do
testZStore :: Test
testZStore = testCase "zunionstore/zinterstore" $ do
- Right _ <- zadd "k1" [(1, "v1"), (2, "v2")]
- Right _ <- zadd "k2" [(2, "v2"), (3, "v3")]
+ zadd "k1" [(1, "v1"), (2, "v2")] >>= \case
+ Left _ -> error "error"
+ _ -> return ()
+ zadd "k2" [(2, "v2"), (3, "v3")] >>= \case
+ Left _ -> error "error"
+ _ -> return ()
zinterstore "newkey" ["k1","k2"] Sum >>=? 1
zinterstoreWeights "newkey" [("k1",1),("k2",2)] Max >>=? 1
zunionstore "newkey" ["k1","k2"] Sum >>=? 3
@@ -372,17 +388,29 @@ testZStore = testCase "zunionstore/zinterstore" $ do
testHyperLogLog :: Test
testHyperLogLog = testCase "hyperloglog" $ do
-- test creation
- Right _ <- pfadd "hll1" ["a"]
+ pfadd "hll1" ["a"] >>= \case
+ Left _ -> error "error"
+ _ -> return ()
pfcount ["hll1"] >>=? 1
-- test cardinality
- Right _ <- pfadd "hll1" ["a"]
+ pfadd "hll1" ["a"] >>= \case
+ Left _ -> error "error"
+ _ -> return ()
pfcount ["hll1"] >>=? 1
- Right _ <- pfadd "hll1" ["b", "c", "foo", "bar"]
+ pfadd "hll1" ["b", "c", "foo", "bar"] >>= \case
+ Left _ -> error "error"
+ _ -> return ()
pfcount ["hll1"] >>=? 5
-- test merge
- Right _ <- pfadd "hll2" ["1", "2", "3"]
- Right _ <- pfadd "hll3" ["4", "5", "6"]
- Right _ <- pfmerge "hll4" ["hll2", "hll3"]
+ pfadd "hll2" ["1", "2", "3"] >>= \case
+ Left _ -> error "error"
+ _ -> return ()
+ pfadd "hll3" ["4", "5", "6"] >>= \case
+ Left _ -> error "error"
+ _ -> return ()
+ pfmerge "hll4" ["hll2", "hll3"] >>= \case
+ Left _ -> error "error"
+ _ -> return ()
pfcount ["hll4"] >>=? 6
-- test union cardinality
pfcount ["hll2", "hll3"] >>=? 6
@@ -425,8 +453,12 @@ testTransaction :: Test
testTransaction = testCase "transaction" $ do
watch ["k1", "k2"] >>=? Ok
unwatch >>=? Ok
- Right _ <- set "foo" "foo"
- Right _ <- set "bar" "bar"
+ set "foo" "foo" >>= \case
+ Left _ -> error "error"
+ _ -> return ()
+ set "bar" "bar" >>= \case
+ Left _ -> error "error"
+ _ -> return ()
foobar <- multiExec $ do
foo <- get "foo"
bar <- get "bar"
@@ -443,25 +475,29 @@ testScripting conn = testCase "scripting" go conn
go = do
let script = "return {false, 42}"
scriptRes = (False, 42 :: Integer)
- Right scriptHash <- scriptLoad script
- eval script [] [] >>=? scriptRes
- evalsha scriptHash [] [] >>=? scriptRes
- scriptExists [scriptHash, "notAScript"] >>=? [True, False]
- scriptFlush >>=? Ok
- -- start long running script from another client
- configSet "lua-time-limit" "100" >>=? Ok
- evalFinished <- liftIO newEmptyMVar
- asyncScripting <- liftIO $ Async.async $ runRedis conn $ do
- -- we must pattern match to block the thread
- Left _ <- eval "while true do end" [] []
- :: Redis (Either Reply Integer)
- liftIO (putMVar evalFinished ())
+ scriptLoad script >>= \case
+ Left _ -> error "error"
+ Right scriptHash -> do
+ eval script [] [] >>=? scriptRes
+ evalsha scriptHash [] [] >>=? scriptRes
+ scriptExists [scriptHash, "notAScript"] >>=? [True, False]
+ scriptFlush >>=? Ok
+ -- start long running script from another client
+ configSet "lua-time-limit" "100" >>=? Ok
+ evalFinished <- liftIO newEmptyMVar
+ asyncScripting <- liftIO $ Async.async $ runRedis conn $ do
+ -- we must pattern match to block the thread
+ (eval "while true do end" [] []
+ :: Redis (Either Reply Integer)) >>= \case
+ Left _ -> return ()
+ _ -> error "impossible"
+ liftIO (putMVar evalFinished ())
+ return ()
+ liftIO (threadDelay 500000) -- 0.5s
+ scriptKill >>=? Ok
+ () <- liftIO (takeMVar evalFinished)
+ liftIO $ Async.wait asyncScripting
return ()
- liftIO (threadDelay 500000) -- 0.5s
- scriptKill >>=? Ok
- () <- liftIO (takeMVar evalFinished)
- liftIO $ Async.wait asyncScripting
- return ()
------------------------------------------------------------------------------
-- Connection
@@ -533,17 +569,23 @@ testsServer =
testServer :: Test
testServer = testCase "server" $ do
- Right (_,_) <- time
+ time >>= \case
+ Right (_,_) -> return ()
+ Left _ -> error "error"
slaveof "no" "one" >>=? Ok
return ()
testBgrewriteaof :: Test
testBgrewriteaof = testCase "bgrewriteaof/bgsave/save" $ do
save >>=? Ok
- Right (Status _) <- bgsave
+ bgsave >>= \case
+ Right (Status _) -> return ()
+ _ -> error "error"
-- Redis needs time to finish the bgsave
liftIO $ threadDelay (10^(5 :: Int))
- Right (Status _) <- bgrewriteaof
+ bgrewriteaof >>= \case
+ Right (Status _) -> return ()
+ _ -> error "error"
return ()
testConfig :: Test
@@ -560,8 +602,12 @@ testFlushall = testCase "flushall/flushdb" $ do
testInfo :: Test
testInfo = testCase "info/lastsave/dbsize" $ do
- Right _ <- info
- Right _ <- lastsave
+ info >>= \case
+ Left _ -> error "error"
+ _ -> return ()
+ lastsave >>= \case
+ Left _ -> error "error"
+ _ -> return ()
dbsize >>=? 0
configResetstat >>=? Ok
@@ -574,7 +620,9 @@ testSlowlog = testCase "slowlog" $ do
testDebugObject :: Test
testDebugObject = testCase "debugObject/debugSegfault" $ do
set "key" "value" >>=? Ok
- Right _ <- debugObject "key"
+ debugObject "key" >>= \case
+ Left _ -> error "error"
+ _ -> return ()
return ()
testScans :: Test