hedis-tags (empty) → 0.1.0
raw patch · 6 files changed
+312/−0 lines, 6 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, bytestring, hedis, hedis-tags, lifted-base, test-framework, test-framework-hunit, test-framework-quickcheck2, transformers
Files
- LICENSE +25/−0
- Setup.hs +2/−0
- hedis-tags.cabal +50/−0
- src/Database/Redis/Tags.hs +103/−0
- test/Database/Redis/Tags/Test/Tags.hs +120/−0
- test/Main.hs +12/−0
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2011, John Lenz. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ hedis-tags.cabal view
@@ -0,0 +1,50 @@+name: hedis-tags+version: 0.1.0+cabal-version: >= 1.8+build-type: Simple+stability: Experimental+author: Alexander Dorofeev <aka.spin@gmail.com>+maintainer: Alexander Dorofeev <aka.spin@gmail.com>+synopsis: Tags for hedis+license: BSD3+description: Brain-free tags for Redis.+category: Database+license-file: LICENSE +homepage: https://github.com/akaspin/hedis-tags++source-repository head+ type: git+ location: git://github.com/akaspin/hedis-tags.git ++library+ hs-source-dirs: src+ build-depends: base >= 4 && < 5,+ bytestring >= 0.9 && < 0.10,+ hedis >= 0.3 && < 0.4+ ghc-options: -Wall+ exposed-modules: Database.Redis.Tags++test-suite test+ type: exitcode-stdio-1.0+ x-uses-tf: true+ hs-source-dirs: test+ build-depends: + base >= 4,+ HUnit >= 1.2 && < 2,+ QuickCheck >= 2.4,+ test-framework >= 0.4.1,+ test-framework-quickcheck2,+ test-framework-hunit,+ + hedis-tags,+ + -- from lib+ bytestring >= 0.9 && < 0.10,+ hedis >= 0.3 && < 0.4,+ + lifted-base,+ transformers+ ghc-options: -Wall -rtsopts -threaded+ main-is: Main.hs+ other-modules: Database.Redis.Tags.Test.Tags+
+ src/Database/Redis/Tags.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE OverloadedStrings #-} + +-- | Hedis tags helper. + +module Database.Redis.Tags ( + -- * Tagging + markTags, + purgeTags, + nestTags, + -- * Maintenance + reconsileTags +) where + +import qualified Data.ByteString as B +import qualified Database.Redis as R +import Data.Either (rights) + +import Control.Monad (void, filterM) + +-- | Mark keys with tags. Keys may be absent. All tags named in next manner: +-- +-- > tag-prefix:tag:tag-signature +-- +-- Tags stored in Redis as sets with no expiration. Tags not related to +-- each other. +-- +-- /Time complexity/ @O(K+T)@ where @K@ and @T@ is number of keys and tags. +markTags :: + [B.ByteString] -- ^ Keys. + -> B.ByteString -- ^ Prefix for tags. + -> [B.ByteString] -- ^ Tags. To make list of nested tags use 'nestTags'. + -> R.Redis () +markTags [] _ _ = return () +markTags _ _ [] = return () +markTags keys pref tags = + let pt = map (tagName pref) tags in + void $ mapM (`R.sadd` keys) pt + +-- | Purge tagged keys and tags. +-- +-- Because the tags are not related to each other, if key tagged with more +-- than one tags, remember the following. After removal of one of the tags, +-- may remain orphans. To avoid this, purge all needed tags or use +-- 'reconcileTags' for stripping. +-- +-- /Time complexity/ @~O(T+2K)@ where @T@ is number tags and @K@ is number +-- of tagged keys. +purgeTags :: + B.ByteString -- ^ Prefix for tags. + -> [B.ByteString] -- ^ Tags. To make list of nested tags use 'nestTags'. + -> R.Redis () +purgeTags _ [] = return () +purgeTags pref tags = do + let pt = map (tagName pref) tags + a <- R.sunion pt + let keys = head $ rights [a] + void $ R.del pt + void $ R.del keys + +-- | Helper for create list of nested tags. +-- +-- > nestTags ["one", "two", "three"] +-- > ["one", "one:two", "one:two:three"] +nestTags :: [B.ByteString] -> [B.ByteString] +nestTags = scanl1 (\a b -> B.append a $ B.append ":" b) + +-- | Reconcile all tags with given prefix. +-- +-- * Remove noexistent keys from tags. +-- +-- * Remove empty tags. +-- +-- This operation take huge time complexity. Use it only for maintenance. +reconsileTags :: + B.ByteString -- ^ Tags prefix. + -> R.Redis () +reconsileTags pref = do + allTags <- R.keys $ tagName pref "*" + needRem <- filterM reconsileTag $ head $ rights [allTags] + void $ R.del needRem + where + reconsileTag t = do + keys <- R.smembers t + let keys' = head $ rights [keys] + needRem <- filterM checkKey keys' + if needRem == keys' + then return True + else do + void $ R.srem t needRem + return False + checkKey k = do + ex <- R.exists k + return $ case ex of + Right False -> True + _ -> False + +----------------------------------------------------------------------------- +-- Internal +----------------------------------------------------------------------------- + +-- | Make tag name with prefix +tagName :: B.ByteString -> B.ByteString -> B.ByteString +tagName pref = (pref `B.append` ":tag:" `B.append`)
+ test/Database/Redis/Tags/Test/Tags.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings, RankNTypes #-} +-- | Tags tests + +module Database.Redis.Tags.Test.Tags (tests) where + +import Test.Framework (testGroup, mutuallyExclusive, Test) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) + +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Control.Exception.Lifted (bracket_) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 + +import qualified Database.Redis as R +import qualified Database.Redis.Tags as RT +import Data.List (sort) + +tests :: Test +tests = mutuallyExclusive $ testGroup "Tags" [ + testCase "Nested tags" caseNestTags, + testCase "Mark" caseMark, + testCase "Purge" casePurge, + testCase "Reconcile" caseReconsile + ] + +caseNestTags :: Assertion +caseNestTags = do + let expect = ["one", "one:two", "one:two:three"] + expect @=? RT.nestTags ["one", "two", "three"] + +caseMark :: Assertion +caseMark = bracket_ + setup + teardown + $ runInRedis $ do + let expected = appendPrefix . scrap $ [1..9] + RT.markTags expected + allPrefix + (scrap [1..3]) + let tags = appendPrefix . map (":tag:" `B.append`) $ scrap [1..3] + res <- mapM R.smembers tags + mapM_ (liftIO . + (Right expected @=?) . + fmap sort) res + +casePurge :: Assertion +casePurge = bracket_ + setup + teardown + $ runInRedis $ do + let expected = appendPrefix . scrap $ [1..9] + let tags = appendPrefix . map (":tag:" `B.append`) $ scrap [1..3] + RT.markTags expected + allPrefix + (scrap [1..3]) + RT.purgeTags allPrefix (scrap [1..3]) + mapM_ (\k -> do + ex <- R.exists k + liftIO $ ex @=? Right False + ) expected + mapM_ (\k -> do + ex <- R.exists k + liftIO $ ex @=? Right False + ) tags + +caseReconsile :: Assertion +caseReconsile = bracket_ + setup + teardown + $ runInRedis $ do + let expected = appendPrefix . scrap $ [1..9] + let tags = appendPrefix . map (":tag:" `B.append`) $ scrap [1..3] + RT.markTags expected + allPrefix + (scrap [1..3]) + void $ R.del $ appendPrefix . scrap $ [1..8] + RT.reconsileTags allPrefix + t <- R.keys $ allPrefix `B.append` ":tag:*" + k <- R.sunion tags + liftIO $ Right tags @=? t + liftIO $ Right ["redistags9"] @=? k + void $ R.del $ appendPrefix . scrap $ [1..9] + RT.reconsileTags allPrefix + t' <- R.keys $ allPrefix `B.append` ":tag:*" + k' <- R.sunion tags + liftIO $ Right [] @=? t' + liftIO $ Right [] @=? k' + + +runInRedis :: forall b. R.Redis b -> IO b +runInRedis a = do + conn <- R.connect R.defaultConnectInfo + R.runRedis conn a + +-- | Populate keys +setup :: IO () +setup = runInRedis $ void $ R.mset $ zip + (appendPrefix . scrap $ [1..100]) + (appendPrefix . scrap $ [1..100]) + +-- | Purge all keys with 'allPrefix' +teardown :: IO () +teardown = runInRedis $ do + a <- R.keys $ allPrefix `B.append` "*" + _ <- either undefined R.del a + return () + +-- | Scrap bytestring list +scrap :: [Int] -> [B.ByteString] +scrap = map (B8.pack . show) + +appendPrefix :: [B.ByteString] -> [B.ByteString] +appendPrefix = map (allPrefix `B.append`) + +allPrefix :: B.ByteString +allPrefix = "redistags" +
+ test/Main.hs view
@@ -0,0 +1,12 @@+ +module Main (main) where + +import Test.Framework (defaultMain) + +import qualified Database.Redis.Tags.Test.Tags + +main :: IO () +main = defaultMain [ + Database.Redis.Tags.Test.Tags.tests + ] +