hedis-pile 0.5.2 → 0.5.3

raw patch · 3 files changed

+66/−18 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• hedis-pile.cabal +1/−1
• src/Database/Redis/Pile.hs +31/−16
• test/Database/Redis/Test/Pile.hs +34/−1

@@ -1,5 +1,5 @@ name:           hedis-pile
-version:        0.5.2
+version:        0.5.3
 cabal-version:  >= 1.8
 build-type:     Simple
 stability:      Experimental

@@ -29,7 +29,7 @@ 
 -- | 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.
+--   remove it from the cache.
 --   
 --   Computation controls everything except prefix and key.
 --
@@ -38,11 +38,11 @@ --
 --   Time complexity depends on the situation. 
 --   
---   * @O(1)@ data exists in cache, expect matches. 
+--   * @O(2)@ data exists in cache, expect matches. 
 --   
---   * @O(1)@ data exists in cache, expect value is 'Nothing'.
+--   * @O(2)@ data exists in cache, expect value is 'Nothing'.
 --   
---   * @O(2)@ data exists in cache, but expect value not matches value 
+--   * @O(3)@ data exists in cache, but expect value not matches value 
 --     in cache.
 --   
 --   * In all other cases time complexity does not make sense
@@ -62,31 +62,46 @@             --   optional TTL. 
             --   All tags will be stored as @prefix:tag@.
     -> ma (Maybe d)
-pile prx key (Just ev) fn = do
-    res <- R.hget (prx <> ":" <> key) "e"
+pile keyPrefix key (Just ev) fn = do
+    res <- R.hget (keyPrefix <> ":" <> key) "e"
     case res of
         Right (Just ev') | ev' == ev -> return Nothing
-                         | otherwise -> pile prx key Nothing fn
-        _ -> pile prx key Nothing fn
-pile prx key Nothing fn = do 
+                         | otherwise -> pile keyPrefix key Nothing fn
+        _ -> pile keyPrefix key Nothing fn
+pile keyPrefix key Nothing fn = do 
     res <- fetchPayload
     case res of
         Nothing -> runFn
         Just res' -> return . Just . decode . cs $ res'  
   where
-    withPrefix = prx <> ":" <> key
+    withPrefix = keyPrefix <> ":" <> key
     fetchPayload = do
         v <- R.hget withPrefix "d"
         return $ case v of 
             Right (Just v') -> Just v'
             _ -> Nothing
     runFn = do
-        (dt, ev', ts, ttl) <- fn
-        let dt' = cs . encode $ dt
-        void $ R.hmset withPrefix [("e", ev'), ("d", dt')]
-        setExpire ttl
-        RT.markTags [withPrefix] prx ts
-        return $ Just dt
+        -- run and encode data
+        (newData, newExpectValue, tags, ttl) <- fn
+        let encodedData = cs . encode $ newData
+        
+        -- Try to get data. 
+        maybeInCache <- R.hget withPrefix "d"
+        case maybeInCache of
+            Right Nothing -> do
+                -- no data in cache. store and return
+                void $ R.hmset withPrefix 
+                    [("e", newExpectValue), ("d", encodedData)]
+                setExpire ttl
+                RT.markTags [withPrefix] keyPrefix tags
+                return $ Just newData
+            Right (Just cachedData) -> 
+                -- data in cache. dont set. just return
+                return . Just . decode . cs $ cachedData
+            _ -> 
+                -- some troubles. just return
+                return $ Just newData
+        
       where
         setExpire Nothing = return ()
         setExpire (Just ke) = void $ R.expire withPrefix ke

@@ -10,6 +10,7 @@ import Control.Monad (void)
 import Control.Monad.IO.Class (liftIO)
 import Control.Exception.Lifted (bracket_)
+import Control.Concurrent.Lifted (threadDelay)
 
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL
@@ -23,11 +24,43 @@ 
 tests :: Test
 tests = mutuallyExclusive $ testGroup "Pile" [
-    testCase "Binary test" caseBinary,
+    testCase "Expire" caseExpire,
+    testCase "Binary" caseBinary,
     testCase "Just Put & Get" casePutGet,
     testCase "Put and get without expect" caseWithoutTag,
     testCase "Put and get with expect" caseWithTag
     ]
+
+caseExpire :: Assertion
+caseExpire = bracket_
+    setup
+    teardown $ runInRedis $ do
+        -- test noexistent
+        noexistRes <- R.exists tName
+        liftIO $ Right False @=? noexistRes
+        
+        -- set test key and try to get
+        _ <- R.hset tName "payload" "*"
+        existRes <- R.exists tName
+        liftIO $ Right True @=? existRes
+        existsVal <- R.hget tName "payload"
+        liftIO $ Right (Just "*") @=? existsVal
+        
+        -- expire key. and wait
+        _ <- R.expire tName 1
+        liftIO $ threadDelay 1500000
+        
+        -- check existence
+        existRes' <- R.exists tName
+        liftIO $ Right False @=? existRes'
+        
+        -- try get
+        expiredRes <- R.hget tName "payload"
+        liftIO $ Right Nothing @=? expiredRes
+        
+  where
+    tName = testPrefix <> "existence"
+    
 
 -- | Binary checks
 caseBinary :: Assertion