Skip to content
Browse files

all tests

Signed-off-by: Alexander Dorofeev <aka.spin@gmail.com>
  • Loading branch information...
1 parent fc39caf commit f961520d1e7b0855f59a6d9117872b55c63bbb3e @akaspin committed
Showing with 64 additions and 14 deletions.
  1. +4 −3 src/Database/Redis/Pile.hs
  2. +60 −11 test/Database/Redis/Test/Pile.hs
View
7 src/Database/Redis/Pile.hs
@@ -23,11 +23,12 @@ import Control.Monad (void)
import qualified Data.ByteString as B
import Data.Binary (Binary(..), encode, decode)
import Data.String.Conversions ((<>), cs)
-import Data.Maybe (fromJust)
import qualified Database.Redis as R
import qualified Database.Redis.Tags as RT
+--import Control.Monad.IO.Class (liftIO)
+
-- | Stores computation results in Redis. Computation fires only
-- if data absent in cache. Of course, to refresh the data, they must first
-- remove from the cache.
@@ -45,7 +46,7 @@ import qualified Database.Redis.Tags as RT
--
-- * @O(2)@
-pile :: forall ma d . (MonadIO ma, ma ~ R.Redis, Binary d) =>
+pile :: forall ma d . (MonadIO ma, ma ~ R.Redis, Binary d, Show d) =>
B.ByteString
-- ^ Prefix for key and tags.
-> B.ByteString
@@ -70,7 +71,7 @@ pile prx key Nothing fn = do
res <- fetchPayload
case res of
Nothing -> runFn
- Just res' -> return $ Just . fromJust . decode . cs $ res'
+ Just res' -> return $ Just $ decode $ cs res'
where
withPrefix = prx <> ":" <> key
fetchPayload = do
View
71 test/Database/Redis/Test/Pile.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
module Database.Redis.Test.Pile (tests) where
@@ -19,19 +19,25 @@ import Data.String.Conversions ((<>), cs)
import qualified Database.Redis as R
import qualified Database.Redis.Pile as RP
+import Data.Binary (encode, decode)
+
tests :: Test
tests = mutuallyExclusive $ testGroup "Pile" [
- testCase "Just Put & Get" casePutGet
--- testCase "Stored data" caseStoredData
+ testCase "Binary test" caseBinary,
+ testCase "Just Put & Get" casePutGet,
+ testCase "Put and get without expect" caseWithoutTag,
+ testCase "Put and get with expect" caseWithTag
]
+-- | Binary checks
+caseBinary :: Assertion
+caseBinary = do
+ let d1 = (1 :: Int, "a" :: B.ByteString)
+ let a1 = encode d1
+ let d2 = decode a1 :: (Int, B.ByteString)
+ liftIO $ d1 @=? d2
-
-runInRedis :: forall b. R.Redis b -> IO b
-runInRedis a = do
- conn <- R.connect R.defaultConnectInfo
- R.runRedis conn a
-
+-- | Just do put-get routine
casePutGet :: Assertion
casePutGet = bracket_
setup
@@ -39,27 +45,70 @@ casePutGet = bracket_
r <- RP.pile testPrefix (toBs 1) Nothing $
return (testData 1, "exp", [], Nothing)
liftIO $ r @=? Just (testData 1)
+
+-- | Work without tag
+caseWithoutTag :: Assertion
+caseWithoutTag = bracket_
+ setup
+ teardown $ runInRedis $ do
+ r1 <- RP.pile testPrefix (toBs 1) Nothing $
+ return (testData 1, "exp", [], Nothing)
+ (r2 :: Maybe TData) <- RP.pile testPrefix (toBs 1) Nothing $
+ return (testData 1, "exp", [], Nothing)
+ liftIO $ r1 @=? r2
+
+-- | Work with tag
+caseWithTag :: Assertion
+caseWithTag = bracket_
+ setup
+ teardown $ runInRedis $ do
+ -- prepend data
+ _ <- RP.pile testPrefix (toBs 1) (Just "exp") $
+ return (testData 1, "exp", [], Nothing)
+ -- retrieve with matching expect
+ r2 <- RP.pile testPrefix (toBs 1) (Just "exp") $
+ return (testData 1, "exp", [], Nothing)
+ liftIO $ r2 @=? Nothing
+ -- retrieve with unmatching expect
+ r3 <- RP.pile testPrefix (toBs 1) (Just "exp_no_match") $
+ return (testData 1, "exp", [], Nothing)
+ liftIO $ r3 @=? Just (testData 1)
+
+-- | Run in redis
+runInRedis :: forall b. R.Redis b -> IO b
+runInRedis a = do
+ conn <- R.connect R.defaultConnectInfo
+ R.runRedis conn a
+-- | Test setup
setup :: IO ()
setup = runInRedis $
void $ R.hmset (testPrefix <> ":mark") [("mark", "mark")]
--- | Purge all keys with 'allPrefix'
+-- | Teardown. Purge all keys with 'allPrefix'
teardown :: IO ()
teardown = runInRedis $ do
a <- R.keys $ testPrefix <> "*"
_ <- either undefined R.del a
return ()
+-- | Common prefix
testPrefix :: B.ByteString
testPrefix = "piletest"
-testData :: Int -> (Int, [(B.ByteString, Maybe B.ByteString)], BL.ByteString)
+type TData = (Int, [(B.ByteString, Maybe B.ByteString)], BL.ByteString)
+
+-- | Common data
+testData ::
+ Int -- ^ Param-param
+ -> TData
testData n =
(n, [(toBs n, Just $ toBs n)], toLBs n)
+-- | Convert int to bytestring
toBs :: Int -> B.ByteString
toBs n = cs . show $ n
+-- | Convert int to lazy bytestring
toLBs :: Int -> BL.ByteString
toLBs n = cs . show $ n

0 comments on commit f961520

Please sign in to comment.
Something went wrong with that request. Please try again.