packages feed

hlrdb-core (empty) → 0.1.0.0

raw patch · 12 files changed

+905/−0 lines, 12 filesdep +basedep +bytestringdep +hashablesetup-changed

Dependencies added: base, bytestring, hashable, hedis, lens, mtl, profunctors, random, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2017 Identical Snowflake++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hlrdb-core.cabal view
@@ -0,0 +1,56 @@+name:                hlrdb-core+version:             0.1.0.0+synopsis:            High-level Redis Database Core API+description:         A library for type-driven interaction with Redis+license:             MIT+license-file:        LICENSE+author:              Identical Snowflake+maintainer:          identicalsnowflake@protonmail.com+category:            Database+build-type:          Simple+cabal-version:       2.0+homepage:            https://github.com/identicalsnowflake/hlrdb-core+bug-reports:         https://github.com/identicalsnowflake/hlrdb-core/issues++source-repository head+  type:     git+  location: https://github.com/identicalsnowflake/hlrdb-core++library+  exposed-modules:+      HLRDB.Core+    , HLRDB.Primitives.Aggregate+    , HLRDB.Primitives.Redis+    , HLRDB.Structures.Basic+    , HLRDB.Structures.HSet+    , HLRDB.Structures.List+    , HLRDB.Structures.Set+    , HLRDB.Structures.SSet+    , HLRDB.Internal+  build-depends:+      base >= 4.9 && < 5.0+    , bytestring ^>= 0.10.8.1+    , hashable ^>= 1.2.6.1+    , hedis ^>= 0.10.1+    , lens ^>= 4.16+    , mtl ^>= 2.2.2+    , profunctors ^>= 5.2.2+    , random ^>= 1.1+    , unordered-containers ^>= 0.2.8.0+  hs-source-dirs:      src+  default-language:    Haskell2010+  default-extensions:+      BangPatterns+    , DataKinds+    , DeriveGeneric+    , DeriveTraversable+    , FlexibleContexts+    , GADTs+    , LambdaCase+    , OverloadedStrings+    , RankNTypes+    , ScopedTypeVariables+    , TypeOperators++  ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -fwarn-tabs+
+ src/HLRDB/Core.hs view
@@ -0,0 +1,85 @@+-- | This package is an abstract API for modeling high-level Redis functionality. It makes no opinion on either serialization or key construction, which means there is a fair amount of work to do to make this library usable. If you do not want to do this work and don't mind these decisions being made for you, you may use the HLRDB library, which gives you a ready-to-go API.+-- +-- This package depends on the Hedis library for low-level Redis bindings, but it is not recommended to import them together in the same module, as there are many name conflicts, since much of what HLRDB does is simply assign types to commands. Despite this, much of the HLRDB API does differ entirely, with many commands added, removed, merged, or simply rethought from a Haskell perspective.+--+-- When using this package, you should always ensure that your Eq instances respect the induced equality via whatever serialization mechanism you've specified, since many commands perform comparisons in Redis directly.++module HLRDB.Core+       (+         -- * Basic+         get+       , liftq+       , mget+       , set+       , set'+       , incr+       , incrby+       , decr+       , decrby++         -- * List         +       , lrange+       , lprepend+       , lappend+       , lpop+       , lrem+       , llen++         -- * HSet+       , hgetall+       , hget+       , hmget+       , hset+       , hmset+       , hdel+       , hsetnx+       , hscan++         -- * Set+       , smembers+       , sismember+       , sadd+       , srem+       , scard+       , srandmember+       , sscan++         -- * SSet+       , zadd+       , zscore+       , zupdate+       , zbest+       , zworst+       , zmember+       , zrank+       , zrevrank+       , zrem+       , zincrby+       , zcard+       , zscan++         -- * Re-exports from hedis+       , Redis+       , MonadRedis+       , liftRedis+       , Cursor+       , cursor0++         -- * HLRDB Primitive re-exports+       +       , module HLRDB.Primitives.Aggregate+       , module HLRDB.Primitives.Redis+       +       ) where++import Database.Redis (Redis,MonadRedis,liftRedis,Cursor,cursor0)++import HLRDB.Primitives.Aggregate+import HLRDB.Primitives.Redis++import HLRDB.Structures.Basic+import HLRDB.Structures.List+import HLRDB.Structures.HSet+import HLRDB.Structures.Set+import HLRDB.Structures.SSet+
+ src/HLRDB/Internal.hs view
@@ -0,0 +1,134 @@+-- | Internal module. Not intended for public use.++module HLRDB.Internal+       (+         probIO+       , primKey+       , unwrap+       , unwrapCursor+       , unwrapCreatedBool+       , unwrapCreated+       , unwrapDeleted+       , ignore+       , fixEmpty+       , fixEmpty'+       , foldM+       , decodeMInteger+       , readInt+       , Int64+       , runIdentity+       ) where++import Data.Functor.Identity+import Database.Redis+import Data.ByteString hiding (foldr)+import HLRDB.Primitives.Redis+import qualified Data.ByteString as S+import qualified Data.ByteString.Unsafe as B+import GHC.Int+import Control.Monad.IO.Class+import System.Random (randomRIO)+++probIO :: (MonadIO m) => Double -> m a -> m (Maybe a)+probIO pr a =+  if pr >= 1.0 then Just <$> a else do+    r :: Double <- liftIO $ randomRIO (0, 1.0)+    if r <= pr+       then Just <$> a+       else return Nothing+++{-# INLINE primKey #-}+primKey :: RedisStructure v a b -> a -> ByteString+primKey (RKeyValue (E e _ _)) k = e k+primKey (RKeyValueInteger e _ _) k = e k+primKey (RList (E e _ _) _) k = e k+primKey (RHSet (E e _ _) _) k = e k+primKey (RSet (E e _ _)) k = e k+primKey (RSortedSet (E e _ _) _) k = e k++-- Redis should never respond with errors if we are using our types consistently,+-- so transform them into exceptions+failRedis :: Reply -> Redis a+failRedis = fail . (++) "Unexpected Redis response: " . show++{-# INLINE unwrap #-}+unwrap :: MonadRedis m => Redis (Either Reply a) -> m a+unwrap r = do+  res <- liftRedis r+  case res of+    Left e -> liftRedis $ failRedis e+    Right i -> return i++{-# INLINE unwrapCursor #-}+unwrapCursor :: MonadRedis m => (a -> b) -> Redis (Either Reply (Cursor , a)) -> m (Maybe Cursor , b)+unwrapCursor f =+  let g (c , x) = (if c == cursor0 then Nothing else Just c , f x) in+  fmap g . unwrap+++{-# INLINE unwrapCreatedBool #-}+unwrapCreatedBool :: MonadRedis m => Redis (Either Reply Bool) -> m (ActionPerformed Creation)+unwrapCreatedBool = fmap (\b -> if b then FreshlyCreated 1 else FreshlyCreated 0) . unwrap++{-# INLINE unwrapCreated #-}+unwrapCreated :: MonadRedis m => Redis (Either Reply Integer) -> m (ActionPerformed Creation)+unwrapCreated = fmap FreshlyCreated . unwrap++{-# INLINE unwrapDeleted #-}+unwrapDeleted :: MonadRedis m => Redis (Either Reply Integer) -> m (ActionPerformed Deletion)+unwrapDeleted = fmap Deleted . unwrap++{-# INLINE ignore #-}+ignore :: (Functor f) => f a -> f ()+ignore = fmap (const ())++-- Redis does not treat treat zero cases properly, so use this to fix the algebra+{-# INLINE fixEmpty #-}+fixEmpty :: (MonadRedis m , Monoid e, Traversable t) => ([ b ] -> Redis e) -> (a -> b) -> t a -> m e+fixEmpty f e t = case foldr ((:) . e) [] t of+  [] -> pure mempty+  xs -> liftRedis $ f xs++{-# INLINE fixEmpty' #-}+fixEmpty' :: (MonadRedis m, Traversable t, Integral i) => ([ b ] -> Redis i) -> (a -> b) -> t a -> m i+fixEmpty' f e t = case foldr ((:) . e) [] t of+  [] -> pure 0+  xs -> liftRedis $ f xs++{-# INLINE foldM #-}+foldM :: (Foldable t) => (a -> b) -> t a -> [ b ]+foldM f t = foldr (\a xs -> f a : xs) [] t++decodeMInteger :: Maybe ByteString -> Int64+decodeMInteger Nothing = 0+decodeMInteger (Just bs) = readInt bs++-- From chrisdone's https://github.com/chrisdone/advent-2017-maze-rust-haskell+readInt :: ByteString -> Int64+readInt as+  | S.null as = 0+  | otherwise =+    case B.unsafeHead as of+      45 -> loop True 0 0 (B.unsafeTail as)+      43 -> loop False 0 0 (B.unsafeTail as)+      _ -> loop False 0 0 as+  where+    loop :: Bool -> Int64 -> Int64 -> S.ByteString -> Int64+    loop neg !i !n !ps+      | S.null ps = end neg i n+      | otherwise =+        case B.unsafeHead ps of+          w+            | w >= 0x30 && w <= 0x39 ->+              loop+                neg+                (i + 1)+                (n * 10 + (fromIntegral w - 0x30))+                (B.unsafeTail ps)+            | otherwise -> end neg i n+    end _ 0 _ = 0+    end True _ n = negate n+    end _ _ n = n+
+ src/HLRDB/Primitives/Aggregate.hs view
@@ -0,0 +1,60 @@+-- | Combinators that can be used for aggregating independent queries. See my <https://identicalsnowflake.github.io/QueryAggregation.html article> about aggregating mget queries for more information.++module HLRDB.Primitives.Aggregate+       (+         T(..)+       , type (⟿)+       , type Query+       , aggregatePair+       , remember+       , runT+       ) where++import Data.Profunctor+import Data.Profunctor.Traversing+import Control.Lens hiding (Traversing)+import Data.ByteString++-- | Abstract representation for aggregation.+newtype T x y a b = T (Traversal a b x y) deriving (Functor)++instance Profunctor (T x y) where+  dimap f g (T t) = T $ \m -> fmap g . t m . f++instance Traversing (T x y) where+  traverse' (T t) = T (traverse . t)++instance Applicative (T x y a) where+  pure x = T $ \_ _ -> pure x+  (<*>) (T f) (T x) = T $ \g a -> f g a <*> x g a++-- | We can merge any two arbitrary mget queries.+{-# INLINE aggregatePair #-}+aggregatePair :: T x y a b -> T x y c d -> T x y (a,c) (b,d)+aggregatePair (T f) (T g) = T $ \h (a,c) ->+  (,) <$> f h a <*> g h c++-- Remember could probably be a Profunctor typeclass in general (is it?)+-- | And we can remember the lookup+remember :: T x y a b -> T x y a (a , b)+remember (T f) = T $ \x a -> (,) a <$> f x a+++instance Strong (T x y) where+  first' = firstTraversing++instance Choice (T x y) where+  left' = leftTraversing++-- | Reify aggregation into a target functor.+{-# INLINE runT #-}+runT :: (Functor f) => ([x] -> f [y]) -> T x y a b -> a -> f b+runT i (T t) = unsafePartsOf t i+++-- | A query using input of type 'a' and yielding an output of type 'b'+type (⟿) a b = T ByteString (Maybe ByteString) a b++-- | Non-infix alias of ⟿+type Query a b = a ⟿ b+
+ src/HLRDB/Primitives/Redis.hs view
@@ -0,0 +1,67 @@+-- | A model for categorizing Redis commands for their particular structures using a GADT.++module HLRDB.Primitives.Redis where++import Data.Functor.Identity+import Data.ByteString++-- | List and SSet declarations allow you to provide a TrimScheme. When provided, HLRDB will automatically trim the structure to the desired cardinality whenever data is inserted.+--+-- For example, if you set a softCardinality of 100 and a trimProbability of 0.05, whenever a data insertion takes place that could bring the cardinality over 100, there will be a 5% chance that a trim command will also be executed. If you want a hard cardinality (to the extent that Redis provides any guarantees), simply set the probability to 1. If you do not want any automatic trimming, simply do not provide a TrimScheme.++data TrimScheme = TrimScheme {+    softCardinality :: Integer+  , trimProbability :: Double+  }++-- | GADT declaring the major Redis data structures. For application-level logic, the simpler type aliases declared below should suffice.+data RedisStructure t a b where+  RKeyValue :: E Maybe a b -> RedisStructure (BASIC ()) a b+  -- Do not allow specifying an encoding for Integer, since Redis commands like incr+  -- demand that *only* the standard encoding is used, e.g., 123 -> "123"+  RKeyValueInteger :: (a -> ByteString) -> (b -> Integer) -> (Integer -> b) -> RedisStructure (BASIC Integer) a b+  RList :: RE a b -> Maybe TrimScheme -> RedisStructure LIST a b+  RHSet :: RE a b -> HSET v -> RedisStructure (HSET v) a b+  RSet :: RE a b -> RedisStructure SET a b+  RSortedSet :: RE a b -> Maybe TrimScheme -> RedisStructure SORTEDSET a b++-- | Alias for simple key-value storage+type RedisBasic k v = RedisStructure (BASIC ()) k v+-- | Alias for simple Integer storage+type RedisIntegral k v = RedisStructure (BASIC Integer) k v+-- | Alias for a Redis List+type RedisList k v = RedisStructure LIST k v+-- | Alias for a Redis HSet+type RedisHSet k s v = RedisStructure (HSET s) k v+-- | Alias for a Redis Set+type RedisSet k v = RedisStructure SET k v+-- | Alias for a Redis SortedSet+type RedisSSet k v = RedisStructure SORTEDSET k v++-- | Many commands in Redis return information about whether items were added/removed or merely updated+data ActionPerformed a where+  FreshlyCreated :: Integer -> ActionPerformed Creation+  Deleted :: Integer -> ActionPerformed Deletion++-- | General primitive encoding. We need a way to serialize the key, and a way to both serialize and deserialize values.+data E f a b = E (a -> ByteString) (b -> f ByteString) (f ByteString -> b)++-- | Most structures don't rely on any special context+type RE a b = E Identity a b++-- | Type-level indicator for Redis basic types+data BASIC a+-- | Type-level indicator for Redis Lists+data LIST+-- | Type-level indicator for Redis HSets with sub-keys of type k; requires a way to serialize and deserialize sub-keys+data HSET k = HSET (k -> ByteString) (ByteString -> k)+-- | Type-level indicator for Redis Sets+data SET+-- | Type-level indicator for Redis SortedSets+data SORTEDSET++-- | Type-level indicator for Creation+data Creation+-- | Type-level indicator for Deletion+data Deletion+
+ src/HLRDB/Structures/Basic.hs view
@@ -0,0 +1,79 @@+-- | Basic storage is simply a key-value lookup in Redis.++module HLRDB.Structures.Basic where++import Database.Redis as Redis+import HLRDB.Primitives.Aggregate+import HLRDB.Primitives.Redis+import HLRDB.Internal+import Data.ByteString.Char8 (pack)+++-- | Simple get command. Works on @RedisBasic a b@ and @RedisIntegral a b@.+get :: MonadRedis m => RedisStructure (BASIC w) a b -> a -> m b+get (RKeyValue (E k _ d)) a = liftRedis $ Redis.get (k a) >>= \case+  Left e -> fail (show e)+  Right r -> pure (d r)+get (RKeyValueInteger k _ d) a = liftRedis $ Redis.get (k a) >>= \case+  Left e -> fail (show e)+  Right r -> pure $ d . fromIntegral $ decodeMInteger r++-- | Construct a query to be used with @mget@. You may combine many of these together to create complex queries. Use @mget@ to execute the query back in the Redis monad. Works on @RedisBasic a b@ and @RedisIntegral a b@.+liftq :: RedisStructure (BASIC w) a b -> a ⟿ b+liftq (RKeyValue (E k _ d)) = T $ \f -> fmap d . f . k+liftq (RKeyValueInteger k _ d) = T $ \f -> fmap (d . fromIntegral . decodeMInteger) . f . k++-- | Reify a (⟿) query into the Redis monad via a single mget command.+mget :: MonadRedis m => a ⟿ b -> a -> m b+mget = runT (liftRedis . mget')+  where+    mget' [] = pure []+    mget' xs = Redis.mget xs >>= \case+      Left e -> fail (show e)+      Right vs -> pure vs++-- | Set a value for a given key. Works on @RedisBasic a b@ and @RedisIntegral a b@.+set :: MonadRedis m => RedisStructure (BASIC w) a b -> a -> b -> m ()+set (RKeyValue (E k e _)) a b = liftRedis $ case e b of+  Just bs -> ignore $ Redis.set (k a) bs+  Nothing -> ignore $ del [ k a ]+set (RKeyValueInteger k e _) a i = liftRedis $ ignore $ Redis.set (k a) (pack $ show (e i))++-- | Convenient alias for setting a value for an optional path+set' :: MonadRedis m => RedisBasic a (Maybe b) -> a -> b -> m ()+set' (RKeyValue (E k e _)) a b = liftRedis $ case e (Just b) of+  Just bs -> ignore $ Redis.set (k a) bs+  Nothing -> ignore $ del [ k a ]++-- | Increment an Integer in Redis. Empty values are treated as 0.+incr :: MonadRedis m => RedisIntegral a b -> a -> m b+incr (RKeyValueInteger p _ d) =+    fmap d+  . unwrap+  . Redis.incr+  . p++-- | Increment an Integer in Redis by a specific amount. Empty values are treated as 0.+incrby :: MonadRedis m => RedisIntegral a b -> a -> b -> m b+incrby (RKeyValueInteger p e d) k =+    fmap d+  . unwrap+  . Redis.incrby (p k)+  . e++-- | Decrement an Integer in Redis. Empty values are treated as 0.+decr :: MonadRedis m => RedisIntegral a b -> a -> m b+decr (RKeyValueInteger p _ d) =+    fmap d+  . unwrap+  . Redis.decr+  . p++-- | Decrement an Integer in Redis by a specific amount. Empty values are treated as 0.+decrby :: MonadRedis m => RedisIntegral a b -> a -> b -> m b+decrby (RKeyValueInteger p e d) k =+    fmap d+  . unwrap+  . Redis.decrby (p k)+  . e+
+ src/HLRDB/Structures/HSet.hs view
@@ -0,0 +1,85 @@+-- | An HSet is a sub-hash table in Redis, indexed by both a key and a subkey.++module HLRDB.Structures.HSet where++import Database.Redis as Redis+import HLRDB.Primitives.Redis+import HLRDB.Internal+import Control.Monad.State++-- I wanted to only have the list get/set commands, but ultimately+-- decided to include the single commands separately because `hset`+-- has a return value which specifies whether a subkey was created or not,+-- whereas hmset does not, and this can be critically useful. Amusingly,+-- even the standard `set` command does not return this information.+++-- | Retrieve all elements of an HSet+hgetall :: MonadRedis m => RedisHSet a s b -> a -> m [ (s,b) ]+hgetall p@(RHSet (E _ _ d) (HSET _ ds)) =+   (fmap . fmap) (\(s,b) -> (ds s , d (pure b)))+ . unwrap+ . Redis.hgetall+ . primKey p++-- | Lookup via key and subkey+hget :: MonadRedis m => RedisHSet a s b -> a -> s -> m (Maybe b)+hget p@(RHSet (E _ _ d) (HSET e _)) k =+    (fmap . fmap) (d . pure)+  . unwrap+  . Redis.hget (primKey p k)+  . e++-- | Lookup via key and subkeys, pairing each given subkey with the lookup result+hmget :: (MonadRedis m , Traversable t) => RedisHSet a s b -> a -> t s -> m (t (s , Maybe b))+hmget p@(RHSet (E _ _ d) (HSET e _)) k t = do+  let f = (fmap . fmap . fmap) (d . pure) . unwrap . Redis.hmget (primKey p k) . fmap e+  let xs = foldr (:) [] t+  reifyTraversal t <$> liftRedis (f xs)+  where+    reifyTraversal :: Traversable t => t a -> [ b ] -> t (a,b)+    reifyTraversal tr bs = evalState (traverse g tr) bs+      where+        g a = do+          (b:bs') <- Control.Monad.State.get+          put bs'+          return (a,b)++-- | Set via key and subkey+hset :: MonadRedis m => RedisHSet a s b -> a -> s -> b -> m (ActionPerformed Creation)+hset p@(RHSet (E _ eb _) (HSET e _)) k s =+    unwrapCreatedBool+  . Redis.hset (primKey p k) (e s)+  . runIdentity+  . eb++-- | Set via key and subkeys+hmset :: (MonadRedis m , Traversable t) => RedisHSet a s b -> a -> t (s , b) -> m ()+hmset p@(RHSet (E _ eb _) (HSET e _)) k =+    liftRedis+  . ignore+  . Redis.hmset (primKey p k)+  . foldr (\x a -> (e (fst x) , runIdentity (eb (snd x))) : a) []+++-- | Delete via key and subkeys+hdel :: (MonadRedis m , Traversable t) => RedisHSet a s b -> a -> t s -> m (ActionPerformed Deletion)+hdel p@(RHSet _ (HSET e _)) k =+    fmap Deleted+  . fixEmpty' (unwrap . Redis.hdel (primKey p k)) e++-- | Set a value only if it does not currently exist in the HSET+hsetnx :: MonadRedis m => RedisHSet a s b -> a -> s -> b -> m (ActionPerformed Creation)+hsetnx p@(RHSet (E _ eb _) (HSET e _)) k s =+    unwrapCreatedBool+  . Redis.hsetnx (primKey p k) (e s)+  . runIdentity+  . eb++-- | Use a cursor to iterate a collection+hscan :: RedisHSet a s b -> a -> Cursor -> Redis (Maybe Cursor , [ (s , b) ])+hscan p@(RHSet (E _ _ d) (HSET _ d')) k =+  let f (a,b) = (d' a , d (pure b)) in+    unwrapCursor (fmap f)+  . Redis.hscan (primKey p k)+
+ src/HLRDB/Structures/List.hs view
@@ -0,0 +1,126 @@+{- | If you've provided a @TrimScheme@ in your structure, adding content (via prepend/append) will trim your list+to preserve this, prioritizing newest content - i.e., prepend commands will result in content+being trimmed from the end on overflow, and append commands will result in content trimmed from+the front on overflow.++-}++module HLRDB.Structures.List+       (+         HLRDB.Structures.List.lrange+       , lprepend+       , lappend+       , HLRDB.Structures.List.lpop+       , HLRDB.Structures.List.lrem+       , HLRDB.Structures.List.llen+       -- * Other commands+       -- | The following commands are available in Redis, but are recommended to use only with caution, due to their behavior being either "unhaskell-ey" or downright exotic.+       , HLRDB.Structures.List.rpop+       , HLRDB.Structures.List.rpoplpush+       , HLRDB.Structures.List.blpop+       , HLRDB.Structures.List.brpop+       , HLRDB.Structures.List.brpoplpush+       ) where++import Database.Redis as Redis+import HLRDB.Primitives.Redis+import HLRDB.Internal+import Data.Maybe (fromJust)+++-- | Retrieve a range of elements. Endpoints are inclusive, just as with Haskell's [ 1 .. 5 ] notation.+lrange :: MonadRedis m => RedisList a b -> a -> Integer -> Integer -> m [ b ]+lrange p@(RList (E _ _ d) _) k i =+    (fmap . fmap) (d . pure)+  . unwrap+  . Redis.lrange (primKey p k) i++-- | Append items to the end of a list+lappend :: (MonadRedis m , Traversable t) => RedisList a b -> a -> t b -> m ()+lappend = addItem True++-- | Prepend items to the front of a list+lprepend :: (MonadRedis m , Traversable t) => RedisList a b -> a -> t b -> m ()+lprepend = addItem False++addItem :: (MonadRedis m , Traversable t) => Bool -> RedisList a b -> a -> t b -> m ()+addItem toTheEnd p@(RList (E _ e _) trimScheme) k bs' =+  let bs = foldr (:) [] bs' in+  case bs of+  [] -> pure ()+  _ -> do+       let method = if toTheEnd then rpush else lpush+       let key = primKey p k+       itemCount <- unwrap $ method key (fmap (runIdentity . e) bs)+       case trimScheme of+         Just (TrimScheme maxItemCount prob) -> fmap (const ()) $ liftRedis $ probIO prob $+           if itemCount > maxItemCount+              then ignore $ if toTheEnd+                   then unwrap $ ltrim key (fromIntegral $ length bs) (-1)+                   else unwrap $ ltrim key 0 (maxItemCount - 1)+              else pure ()+         Nothing -> pure ()++-- | Remove an item from the list. You should ensure that any Eq instance in Haskell respects the induced equality by your encoding scheme, as Redis will use the latter.+lrem :: MonadRedis m => RedisList a b -> a -> b -> m ()+lrem p@(RList (E _ e _) _) k =+    ignore+  . unwrap+  . Redis.lrem (primKey p k) 0+  . runIdentity+  . e++-- | Retrieve the length of a list.+llen :: MonadRedis m => RedisList a b -> a -> m Integer+llen p =+    unwrap+  . Redis.llen+  . primKey p++-- | Remove and return an item from the head of the list.+lpop :: MonadRedis m => RedisList a b -> a -> m (Maybe b)+lpop p@(RList (E _ _ d) _) =+    (fmap . fmap) (d . pure)+  . unwrap+  . Redis.lpop+  . primKey p++-- | Remove and return an item from the end of the list.+rpop :: MonadRedis m => RedisList a b -> a -> m (Maybe b)+rpop p@(RList (E _ _ d) _) =+    (fmap . fmap) (d . pure)+  . unwrap+  . Redis.rpop+  . primKey p++-- | Remove and return an item from the first list and prepend it to the second list.+rpoplpush :: MonadRedis m => RedisList a b -> a -> a -> m (Maybe b)+rpoplpush p@(RList (E _ _ d) _) s =+    (fmap . fmap) (d . pure)+  . unwrap+  . Redis.rpoplpush (primKey p s)+  . primKey p++-- | Blocking variant of rpoplpush+brpoplpush :: MonadRedis m => RedisList a b -> a -> a -> Integer -> m (Maybe b)+brpoplpush p@(RList (E _ _ d) _) s e =+    (fmap . fmap) (d . pure)+  . unwrap+  . Redis.brpoplpush (primKey p s) (primKey p e)++-- | Pop the first available value from a set of lists; if none is available, block the connection (!) until either the specified timeout completes, returning nothing, or until a value becomes available, returning the value and the key of the list in which it was added, whichever happens first. If multiple clients are waiting for an item from the same list, the one who has been waiting the longest will be given the item. If no keys are given, the command returns immediately with Nothing.+blpop :: (MonadRedis m , Traversable t) => RedisList a b -> t a -> Integer -> m (Maybe (a , b))+blpop p@(RList (E e _ d) _) ts t = case foldr (\x a -> (e x , x) : a) [] ts of+  [] -> pure Nothing+  xs ->+    let f (x , b) = (fromJust (lookup x xs) , (d . pure) b) in+    (fmap . fmap . fmap) f unwrap $ Redis.blpop (primKey p . snd <$> xs) t++-- | Similar to blpop, but popping from the right.+brpop :: (MonadRedis m , Traversable t) => RedisList a b -> t a -> Integer -> m (Maybe (a , b))+brpop p@(RList (E e _ d) _) ts t = case foldr (\x a -> (e x , x) : a) [] ts of+  [] -> pure Nothing+  xs ->+    let f (x , b) = (fromJust (lookup x xs) , (d . pure) b) in+    (fmap . fmap . fmap) f unwrap $ Redis.brpop (primKey p . snd <$> xs) t+
+ src/HLRDB/Structures/SSet.hs view
@@ -0,0 +1,132 @@+-- | SortedSets, like lists, support automatic cardinality management when provided a @TrimScheme@.+-- HLRDB exports a more opinionated and less easy-to-make-mistakes API than Redis supports. Scores are golf-(or race) style, where lower numbers are better. The API is setup to make retrieving the best items and discarding the worst items natural, rather than trying to remember which direction the data is sorted in.+-- +-- You should ensure that your Haskell @Eq@ instances respect the equality induced by your encoding scheme, i.e., that @a == b ~ encode a == encode b@.++module HLRDB.Structures.SSet+       (+         HLRDB.Structures.SSet.zadd+       , HLRDB.Structures.SSet.zscore+       , HLRDB.Structures.SSet.zupdate+       , HLRDB.Structures.SSet.zbest+       , HLRDB.Structures.SSet.zworst+       , HLRDB.Structures.SSet.zmember+       , HLRDB.Structures.SSet.zrank+       , HLRDB.Structures.SSet.zrevrank+       , HLRDB.Structures.SSet.zrem+       , HLRDB.Structures.SSet.zincrby+       , HLRDB.Structures.SSet.zcard+       , HLRDB.Structures.SSet.zscan+       ) where++import Control.Lens+import Data.Maybe (isJust)+import Database.Redis as Redis+import HLRDB.Primitives.Redis+import HLRDB.Internal+++trimInternal :: MonadRedis m => RedisSSet a b -> a -> Integer -> m ()+trimInternal p k =+  let f x = x * (-1) - 1 in+    ignore+  . unwrap+  . zremrangebyrank (primKey p k) 0+  . f++trimSortedSet :: MonadRedis m => RedisSSet a b -> a -> Integer -> m ()+trimSortedSet (RSortedSet _ Nothing) _ _ = pure ()+trimSortedSet _ _ 0 = pure ()+trimSortedSet p@(RSortedSet _ (Just (TrimScheme limit 1.0))) k _ =+  trimInternal p k limit+trimSortedSet p@(RSortedSet _ (Just (TrimScheme limit basep))) k count =+  let prob = 1.0 - (1.0 - basep) ^ count in+  liftRedis $ ignore $ probIO prob $ trimInternal p k limit+++-- | Lookup an element's score+zscore :: MonadRedis m => RedisSSet a b -> a -> b -> m (Maybe Double)+zscore p@(RSortedSet (E _ e _) _) k =+    unwrap+  . Redis.zscore (primKey p k)+  . runIdentity+  . e++-- | Add items and scores+zadd :: (MonadRedis m , Traversable t) => RedisSSet a b -> a -> t (Double,b) -> m (ActionPerformed Creation)+zadd p@(RSortedSet (E _ e _) _) k t = do+  i <- fixEmpty' (unwrap . Redis.zadd (primKey p k)) (over _2 (runIdentity . e)) t+  !_ <- trimSortedSet p k i+  pure $ FreshlyCreated (fromIntegral i)++-- | Read the scores from Redis, apply the given trasformation, and write the resulting data+zupdate :: MonadRedis m => RedisSSet a b -> a -> (Double -> Double) -> m ()+zupdate p k f = let key = primKey p k in+  unwrap (zrangeWithscores key 0 (-1)) >>=+  fixEmpty (ignore . unwrap . Redis.zadd key . fmap (\(bs,s) -> (f s , bs))) id++-- | Retrieve the given range of best-performing elements. Range is inclusive, just as with Haskell's [ 1 .. 5 ] notation, and it is 0-based, which means [ 0 .. 4 ] is what corresponds to the English phrase "Best 5."+zbest :: MonadRedis m => RedisSSet a b -> a -> Integer -> Integer -> m [ b ]+zbest p@(RSortedSet (E _ _ d) _) k s =+    (fmap . fmap) (d . pure)+  . unwrap+  . zrange (primKey p k) s++-- | Retrieve the given range of worst-performing elements. Range is inclusive, just as with Haskell's [ 1 .. 5 ] notation, and it is 0-based, which means [ 0 .. 4 ] is what corresponds to the English phrase "Worst 5."+zworst :: MonadRedis m => RedisSSet a b -> a -> Integer -> Integer -> m [ b ]+zworst p@(RSortedSet (E _ _ d) _) k s =+    (fmap . fmap) (d . pure)+  . unwrap+  . zrevrange (primKey p k) s++-- | Test if an object is a member of the set.+zmember :: MonadRedis m => RedisSSet a b -> a -> b -> m Bool+zmember p@(RSortedSet (E _ e _) _) k =+    fmap isJust+  . unwrap+  . Redis.zrank (primKey p k)+  . runIdentity+  . e++-- | Calculate the rank of an item. The best item has rank 0.+zrank :: MonadRedis m => RedisSSet a b -> a -> b -> m (Maybe Integer)+zrank p@(RSortedSet (E _ e _) _) k =+    unwrap+  . Redis.zrank (primKey p k)+  . runIdentity+  . e++-- | Calculate the rank of an item starting from the end, e.g., the worst item has rank 0.+zrevrank :: MonadRedis m => RedisSSet a b -> a -> b -> m (Maybe Integer)+zrevrank p@(RSortedSet (E _ e _) _) k =+    unwrap+  . Redis.zrevrank (primKey p k)+  . runIdentity+  . e++-- | Increment an item's score. If the item does not already exist, it is inserted with the given score.+zincrby :: MonadRedis m => RedisSSet a b -> a -> (Integer,b) -> m Double+zincrby p@(RSortedSet (E _ e _) _) k (s,b) = do+  v <- unwrap $ Redis.zincrby (primKey p k) s $ runIdentity . e $ b+  !_ <- trimSortedSet p k 1+  pure v++-- | Remove items from a sorted set+zrem :: (MonadRedis m , Traversable t) => RedisSSet a b -> a -> t b -> m (ActionPerformed Deletion)+zrem p@(RSortedSet (E _ e _) _) k =+  fmap Deleted <$> fixEmpty' (unwrap . Redis.zrem (primKey p k)) (runIdentity . e)++-- | The cardinality of a sorted set+zcard :: MonadRedis m => RedisSSet a b -> a -> m Integer+zcard p =+    unwrap+  . Redis.zcard+  . primKey p++-- | Use a cursor to iterate a collection.+zscan :: MonadRedis m => RedisSSet a b -> a -> Cursor -> m (Maybe Cursor , [ (b , Double) ])+zscan p@(RSortedSet (E _ _ d) _) k =+  let f (x,s) = (d (pure x) , s) in+    unwrapCursor (fmap f)+  . Redis.zscan (primKey p k)+
+ src/HLRDB/Structures/Set.hs view
@@ -0,0 +1,59 @@+-- | Important: it is required that the Hashable and Eq instances used for HashSet respect+-- whatever is used for serialization, since Redis will decide equality only on serialized values.++module HLRDB.Structures.Set where++import Data.Hashable+import Data.HashSet as S+import Database.Redis as Redis+import HLRDB.Primitives.Redis+import HLRDB.Internal+++-- | Retrieve the elements of a set from Redis+smembers :: (MonadRedis m , Eq b , Hashable b) => RedisSet a b -> a -> m (HashSet b)+smembers p@(RSet (E _ _ d)) =+    fmap (S.fromList . fmap (d . pure))+  . unwrap+  . Redis.smembers+  . primKey p++-- | Test if an item is a member of a set+sismember :: MonadRedis m => RedisSet a b -> a -> b -> m Bool+sismember p@(RSet (E _ e _)) k =+    unwrap+  . Redis.sismember (primKey p k)+  . runIdentity+  . e++-- | Add items to a set+sadd :: (MonadRedis m , Traversable t) => RedisSet a b -> a -> t b -> m ()+sadd p@(RSet (E _ e _)) k =+  fixEmpty (ignore . unwrap . Redis.sadd (primKey p k)) (runIdentity . e)++-- | Remove items from a set+srem :: (MonadRedis m , Traversable t) => RedisSet a b -> a -> t b -> m ()+srem p@(RSet (E _ e _)) k =+  fixEmpty (ignore . unwrap . Redis.srem (primKey p k)) (runIdentity . e)++-- | Retrieve the cardinality of a set+scard :: MonadRedis m => RedisSet a b -> a -> m Integer+scard p =+    unwrap+  . Redis.scard+  . primKey p++-- | Retrieve a random element from a set+srandmember :: MonadRedis m => RedisSet a b -> a -> m (Maybe b)+srandmember p@(RSet (E _ _ d)) =+    (fmap . fmap) (d . pure)+  . unwrap+  . Redis.srandmember+  . primKey p++-- | Use a cursor to iterate a collection+sscan :: MonadRedis m => RedisSet a b -> a -> Cursor -> m (Maybe Cursor , [ b ])+sscan p@(RSet (E _ _ d)) k =+    unwrapCursor (fmap (d . pure))+  . Redis.sscan (primKey p k)+