hedis-pile 0.4.2 → 0.5.0

raw patch · 3 files changed

+143/−120 lines, 3 filesdep +binarydep +string-conversionsdep ~transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: binary, string-conversions

Dependency ranges changed: transformers

API changes (from Hackage documentation)

Files

• hedis-pile.cabal +7/−3
• src/Database/Redis/Pile.hs +61/−80
• test/Database/Redis/Test/Pile.hs +75/−37

@@ -1,5 +1,5 @@ name:           hedis-pile
-version:        0.4.2
+version:        0.5.0
 cabal-version:  >= 1.8
 build-type:     Simple
 stability:      Experimental
@@ -21,9 +21,11 @@   build-depends:   
                    base >= 4 && < 5,
                    bytestring >= 0.9 && < 0.10,
+                   binary,
                    hedis >= 0.4 && < 0.5,
                    hedis-tags >= 0.1,
-                   transformers >= 0.2 && < 0.3
+                   string-conversions,
+                   transformers >= 0.2 && < 0.4
   ghc-options:     -Wall
   exposed-modules: Database.Redis.Pile
 
@@ -45,8 +47,10 @@                    bytestring >= 0.9 && < 0.10,
                    hedis >= 0.4 && < 0.5,
  
+                   binary,
                    lifted-base,
-                   transformers >= 0.2 && < 0.3
+                   string-conversions,
+                   transformers >= 0.2 && < 0.4
   ghc-options:     -Wall -rtsopts -threaded
   main-is:         Main.hs
   other-modules:   Database.Redis.Test.Pile

@@ -1,4 +1,6 @@-{-# LANGUAGE OverloadedStrings, RankNTypes, TypeFamilies #-} 
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
 
 -- | Solution for caching mandatory data with Redis.
 --   
@@ -9,110 +11,89 @@ --   put value to cache ... Tedious
 --   
 --   Solution is quite simple - collapse all of these steps in one operation.
+
 module Database.Redis.Pile (
+    
     pile
 ) where
 
-import qualified Data.ByteString as B
-
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad (void)
 
+import qualified Data.ByteString as B
+import Data.Binary (Binary(..), encode, decode)
+import Data.String.Conversions ((<>), cs)
+
 import qualified Database.Redis as R
 import qualified Database.Redis.Tags as RT
-import Data.Maybe (fromJust)
 
--- | Stores computation results in Redis as hashSet. Computation fires only  
+--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.
 --   
---   Computation controls all that will be stored in the cache except two 
---   things: key and prefix for keys and tags. To do this, 
---   with the results of computation, it may return optional @TTL@ in 
---   seconds (Redis convention) and tags for key. About tags see 
---   "Database.Redis.Tags".
---   
---   Instead get all data from cache, optional parameter allows simply make 
---   sure that cache holds HashSet with needed field with needed value. If this 
---   is so, 'pile' return 'Nothing'. 
+--   Computation controls everything except prefix and key.
 --
--- > conn <- connect defaultConnectInfo
--- > runRedis conn $ do
--- >    -- do it
--- >    r <- pile "myprefix" "mykey" (Just ("etag", "etag")) Nothing $  
--- >        return ([("etag", "etag"), ("val", "myval")], Nothing, [])
--- >    liftIO $ print r
--- >    -- Just [("etag", "etag"), ("val", "myval")]
--- >    
--- >    -- once again
--- >    r <- pile "myprefix" "mykey" (Just ("etag", "etag")) Nothing $  
--- >        return ([("etag", "etag"), ("val", "myval")], Nothing, [])
--- >    liftIO $ print r
--- >    -- Nothing
--- >    
--- >    -- and again without expect
--- >    r <- pile "myprefix" "mykey" Nothing Nothing $  
--- >        return ([("etag", "etag"), ("val", "myval")], Nothing, [])
--- >    liftIO $ print r
--- >    -- Just [("etag", "etag"), ("val", "myval")]
+--   In background data is stored in Redis as HashSet with two fields: @d@ 
+--   for serialized data and @e@ for expect field.
 --
---   Time complexity for cached data:
+--   Time complexity depends on the situation. 
 --   
---   * @O(1)@ If expect matches.
---
---   * @O(2)@ If payload field provided
-pile :: forall ma . (MonadIO ma, ma ~ R.Redis) => 
+--   * @O(1)@ if data exists in cache and expect matches. 
+--   
+--   * @O(1)@ if data exists in cache and expect value is 'Nothing'.
+--   
+--   * @O(2)@
+
+pile :: forall ma d . (MonadIO ma, ma ~ R.Redis, Binary d, Show d) => 
        B.ByteString
             -- ^ Prefix for key and tags.
     -> B.ByteString        
             -- ^ Key in cache. Key will be stored as @prefix:key@
-    -> Maybe (B.ByteString, B.ByteString)
-            -- ^ Optional expect field.
     -> Maybe B.ByteString
-            -- ^ Optional payload field. This reduces time complexity of 
-            --   request data from the cache from @O(N)@ to @O(1)@.
-            --   Regardless of setting this field, all data from computation
-            --   will stored in cache.
-    -> (forall mb . MonadIO mb => mb ([(B.ByteString, B.ByteString)], 
-           Maybe Integer, 
-           [B.ByteString]))
-            -- ^ Computation that returns data and 
-            --   optional TTL and tags. All tags will be stored as @prefix:tag@.
-    -> ma (Maybe [(B.ByteString, B.ByteString)])
-pile p key (Just (ef, ev)) payload f = do
-    e <- R.hget (p `B.append` ":" `B.append` key) ef
-    case e of
+            -- ^ Optional expect value. If it matches the value in the cache,
+            --   'pile' will return 'Nothing'. This is very useful when data in 
+            --   cache can be described with hash. For example, webpage ETag.
+    -> (forall mb . (MonadIO mb) => 
+            mb (d, B.ByteString, [B.ByteString], Maybe Integer))
+            -- ^ Computation that returns data, expect value, tags and 
+            --   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"
+    case res of
         Right (Just ev') | ev' == ev -> return Nothing
-                         | otherwise -> pile p key Nothing payload f
-        _ -> pile p key Nothing payload f
-pile p key Nothing payload f = do
-    d <- fetchPayload payload
-    case d of
-        Nothing -> runF
-        Just r -> return $ Just r
+                         | otherwise -> pile prx key Nothing fn
+        _ -> pile prx key Nothing fn
+pile prx key Nothing fn = do 
+    res <- fetchPayload
+    case res of
+        Nothing -> runFn
+        Just res' -> return $ Just $ decode $ cs res'  
   where
-    fetchPayload Nothing = do
-        v <- R.hgetall withPrefix
-        return $ case v of 
-            Right [] -> Nothing
-            Right r -> Just r
-            _ -> Nothing
-    fetchPayload (Just plf) = do
-        v <- R.hget withPrefix plf
+    withPrefix = prx <> ":" <> key
+    fetchPayload = do
+        v <- R.hget withPrefix "d"
         return $ case v of 
-            Right (Just v') -> Just [(plf, v')]
+            Right (Just v') -> Just v'
             _ -> Nothing
-    
-    withPrefix = p `B.append` ":" `B.append` key
-    runF = do
-        (r, ke, t) <- f
-        void $ R.hmset withPrefix r
-        setExpire ke
-        RT.markTags [withPrefix] p t
-        return $ case payload of
-            Nothing -> Just r
-            Just pl -> Just [(pl, fromJust $ lookup pl r)]
+    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
       where
         setExpire Nothing = return ()
         setExpire (Just ke) = void $ R.expire withPrefix ke
-        
+
+
+
+
+
+
+
+

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
 
 module Database.Redis.Test.Pile (tests) where
 
@@ -12,65 +12,103 @@ import Control.Exception.Lifted (bracket_)
 
 import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
 
+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 "New Data" caseNewData,
-    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
     ]
 
-caseNewData :: Assertion
-caseNewData = bracket_
+-- | 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
+
+-- | Just do put-get routine
+casePutGet :: Assertion
+casePutGet = bracket_ 
     setup
-    teardown
-    $ runInRedis $ do
-        r <- RP.pile allPrefix "two" Nothing Nothing $ 
-            return (allData, Nothing, [])
-        liftIO $ Just allData @=? r
-        void $ RP.pile allPrefix "three" Nothing Nothing $ 
-            return (allData, Just 15, ["one"])
-        ex <- R.ttl $ allPrefix `B.append` ":three"
-        liftIO $ Right 15 @=? ex
-        r' <- RP.pile allPrefix "three" Nothing (Just "anydata") $ 
-            return (allData, Nothing, [])
-        liftIO $ Just [("anydata", "anydata")] @=? r'
-        r'' <- RP.pile allPrefix "three" Nothing (Just "anydata") $ 
-            return (allData, Nothing, [])
-        liftIO $ Just [("anydata", "anydata")] @=? r''
+    teardown $ runInRedis $ do
+        r <- RP.pile testPrefix (toBs 1) Nothing $ 
+                return (testData 1, "exp", [], Nothing)
+        liftIO $ r @=? Just (testData 1)
 
-caseStoredData :: Assertion
-caseStoredData = bracket_
+-- | Work without tag
+caseWithoutTag :: Assertion
+caseWithoutTag = bracket_
     setup
-    teardown
-    $ runInRedis $ do
-        r <- RP.pile allPrefix "one" Nothing Nothing $ 
-            return (allData, Nothing, [])
-        liftIO $ Just allData @=? r
-        r' <- RP.pile allPrefix "one" (Just ("etag", "etag")) Nothing $ 
-            return (allData, Nothing, [])
-        liftIO $ Nothing @=? r'
+    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 "piletest:one" allData
+    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 $ allPrefix `B.append` "*"
+    a <- R.keys $ testPrefix <> "*"
     _ <- either undefined R.del a
     return ()
     
-allPrefix :: B.ByteString
-allPrefix = "piletest"
+-- | Common prefix
+testPrefix :: B.ByteString
+testPrefix = "piletest"
 
-allData :: [(B.ByteString, B.ByteString)]
-allData = [("etag", "etag"), ("anydata", "anydata")]+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