diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# v0.1 + +First public version of `redis-schema`. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Chordify B.V. (c) 2022 + +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. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"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 +OWNER OR CONTRIBUTORS 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,922 @@ +# redis-schema + +A typed, schema-based, composable Redis library. +It strives to provide a solid layer on top of which you can +correctly build your application or another library. + +## Table of contents +* [Table of contents](#table-of-contents) +* [Why `redis-schema`](#why-redis-schema) + * [Statically typed schema](#statically-typed-schema) + * [Hedis](#hedis) + * [`redis-schema`](#redis-schema) + * [Composability](#composability) +* [Tutorial by example](#tutorial-by-example) + * [Simple variables](#simple-variables) + * [Parameterised references](#parameterised-references) + * [Lists, Sets, Hashes, etc.](#lists-sets-hashes-etc) + * [Hashes](#hashes) + * [Aside: Hashes vs. composite keys](#aside-hashes-vs-composite-keys) + * [Records](#records) + * [Aside: non-fixed record fields](#aside-non-fixed-record-fields) + * [Transactions](#transactions) + * [The `Tx` functor](#the-tx-functor) + * [Working with transactions](#working-with-transactions) + * [What Redis transactions cannot do](#what-redis-transactions-cannot-do) + * [Errors in transactions](#errors-in-transactions) + * [Monads vs applicative functors](#monads-vs-applicative-functors) + * [Exceptions](#exceptions) + * [Custom data types](#custom-data-types) + * [Simple values](#simple-values) + * [Non-simple values](#non-simple-values) + * [Redis instances](#redis-instances) + * [Meta-records](#meta-records) + * [Aside: references](#aside-references) + * [Aside: instances](#aside-instances) +* [Libraries](#libraries) + * [Locks](#locks) + * [Remote jobs](#remote-jobs) +* [Future work](#future-work) +* [License](#license) + +## Why `redis-schema` + +### Statically typed schema + +#### Hedis + +The most common Redis library seems to be +[Hedis](https://hackage.haskell.org/package/hedis), and `redis-schema` builds +on top of it. However, consider the type of `get` in Hedis: + +```haskell +get + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f (Maybe ByteString)) +``` + +For most use cases, it would be nice if: +* the value could be decoded from a `ByteString` automatically + * provides convenience but also type safety +* the key could imply the type of the value + * provides type safety + * guides programmer, documents structures, etc. -- everything we love about static types + * it's also immediately clear which instance to use for decoding + +#### `redis-schema` + +In `redis-schema`, the type of `get` is: +```haskell +get :: Ref ref => ref -> RedisM (RefInstance ref) (Maybe (ValueType ref)) +``` +and it makes use of user-supplied declarations: +```haskell +data NumberOfVisitors = NumberOfVisitors Date + +instance Ref NumberOfVisitors where + type ValueType NumberOfVisitors = Integer + toIdentifier (NumberOfVisitors date) = + SviTopLevel $ Redis.colonSep ["number-of-visitors", BS.pack (show date)] +``` + +The differences are: +* Instead of `ByteStrings`, `redis-schema` uses references that are usually + bespoke ADTs, such as `NumberOfVisitors`. +* Bespoke reference types eliminate string operations scattered across the code: + you write `get (NumberOfVisitors today)` instead of + `get ("number-of-visitors:" <> BS.pack (show today))`. + `ByteString` concatenation of course needs to be done somewhere + but it's implemented only once: in the `toIdentifier` method. +* References are more abstract than bytestring keys, which improves composability. + For example, meta-records [use this abstractness](#aside-references), + as a meta-record consists of multiple Redis keys, and thus there's no single bytestring + that could reasonably identify it. +* The `Ref` instance of that data type determines that + the reference stores `Integer`s. This can be seen + in the associated type family `ValueType`. + +More complex data structures, like records, work similarly. + +### Composability + +A major goal of `redis-schema` is to provide typed primitives, +on top of which one can safely and conveniently build further typed libraries, +such as [`Database.Redis.Schema.Lock`](#locks) +or [`Database.Redis.Schema.RemoteJob`](#remote-jobs). +[Meta-records](#meta-records) are another example of how low-level +primitives compose into higher-level "primitives" of the same kind. + +The focus at composability is reflected in the design decisions of various typeclasses, +and in the design and use of Redis transactions to ensure that +composability is not broken by race conditions. + +## Tutorial by example + +Imagine you want to use Redis to count the number of the visitors +on your website. This is how you would do it with `redis-schema`. + +### Simple variables + +(For demonstration purposes, the following example also includes some +basic operations you might *not* do while counting visitors, too. :) ) + +```haskell +-- This module is generally intended to be imported qualified. +import qualified Database.Redis.Schema as Redis + +-- The type of references to the number of visitors. +-- Since we want only one number of visitors, this type is a singleton. +-- Later on, we'll see more interesting types of references. +data NumberOfVisitors = NumberOfVisitors + +-- We define that NumberOfVisitors is indeed a Redis reference. +instance Redis.Ref NumberOfVisitors where + -- The type of the value that NumberOfVisitors refers to is Int. + type ValueType NumberOfVisitors = Int + + -- The location of the value that NumberOfVisitors refers to is "visitors:number". + toIdentifier NumberOfVisitors = "visitors:number" + +f :: Redis.Pool -> IO () +f pool = Redis.run pool $ do + -- write to the reference + set NumberOfVisitors 42 + setTTL NumberOfVisitors (24 * Redis.hour) + + -- atomically increment the number of visitors + incrementBy NumberOfVisitors 1 + + -- atomically read and clear (zero) the reference + -- useful for transactional moves of data + n2 <- take NumberOfVisitors + liftIO $ print n2 + + -- read the value of the reference + n <- get NumberOfVisitors + liftIO $ print n -- this prints "Just 0", assuming no writes from other threads +``` + +### Parameterised references + +If you want a separate counter for every day, +you define a slightly more interesting reference type. + +```haskell +-- Note that the type constructor is still nullary (no parameters) +-- but the data constructor takes the 'Date' in question. +data DailyVisitors = DailyVisitors Date + +instance Redis.Ref DailyVisitors where + -- Again, the reference points to an 'Int'. + -- We're talking about the type of the reference so no date is present here. + type ValueType DailyVisitors = Int + + -- The location does depend on the value of the reference, + -- so it can depend on the date. We include the date in the Redis path. + toIdentifier (DailyVisitors date) = + Redis.colonSep ["visitors", "daily", ByteString.pack (show date)] + +f :: Redis.Pool -> Date -> IO () +f pool today = Redis.run pool $ do + -- atomically bump the number of visitors + incrementBy (DailyVisitors today) 1 + + -- (other threads may modify the value here) + + -- read and print the reference + n <- get (DailyVisitors today) + liftIO $ print n +``` + +With composite keys, it's sometimes useful to use `Redis.colonSep`, +which builds a single colon-separated `ByteString` from the provided components. + +### Lists, Sets, Hashes, etc. + +What we've read/written so far were `SimpleValue`s: data items that can be +encoded as `ByteString`s and used without restrictions. +However, Redis also provides richer data structures, including lists, sets, +and maps/hashes. + +The advantage is that Redis provides operations to manipulate these data +structures directly. You can insert elements, delete elements, etc., without +reading a `ByteString`-encoded structure and writing its modified version back. + +The disadvantage is that Redis does not support nesting them. + +That does not mean there's absolutely no way to put sets in sets -- +if you encode the inner sets into ByteString, you can nest them however you want. +However, you will not be able to use native Redis functions like `sInsert` or `sDelete` +to modify the inner sets; you'd have to read, modify, and write back the entire inner value to do it +-- and that, besides being inconvenient and inefficient, +[cannot be done atomically in Redis](#transactions). + +This is reflected in `redis-schema` by the fact that +the `SimpleValue` instance is not defined for `Set a`, `Map k v` and `[a]`, +which prevents nesting them directly. + +On the other hand, `redis-schema` defines additional functions +specific to these data structures, such as the above mentioned +`sInsert`, which is used to insert elements into a Redis set. + +```haskell +-- The set of visitor IDs for the given date. +data DailyVisitorSet = DailyVisitorSet Date + +instance Redis.Ref DailyVisitorSet where + -- This reference points to a set of visitor IDs. + type ValueType DailyVisitorSet = Set VisitorId + + -- The Redis location of the value. + toIdentifier (DailyVisitorSet date) = + Redis.colonSep ["visitor_set", "daily", ByteString.pack (show date)] + +f :: Redis.Pool -> Date -> VisitorId -> IO () +f pool today vid = Redis.run pool $ do + -- insert the visitor ID + sInsert (DailyVisitorSet today) vid + + -- get the size of the updated set + -- (and print it) + liftIO . print =<< sSize (DailyVisitorSet today) + + -- atomically get and clear the visitor set + -- (and print it) + liftIO . print =<< take (DailyVisitorSet today) +``` + +There is a number of functions available for these structures, +refer to the reference documentation / source code for a complete list. + +Also, we add functions when we need them, so it's quite possible that the function +that you require has not been added yet. Pull requests are welcome. + +### Hashes + +There is a special operator `(:/)` to access the items of a hash, +as if they were individual Redis `Ref`s. +Here's our running example with website visitors, +except that now instead of just the count of visits, or just the set of visitors, +we will store exactly how many times each visitor has visited us. + +```haskell +data Visitors = Visitors Date + +instance Redis.Ref Visitors where + -- Each daily visitor structure is a map from visitor ID to the number of visits. + type ValueType Visitors = Map VisitorId Int + + toIdentifier (Visitors date) = + Redis.colonSep ["visitors", ByteString.pack (show date)] + +f :: Redis.Pool -> Date -> VisitorId -> IO () +f pool today visitorId = do + -- increment one specific counter inside the hash + incrementBy (Visitors today :/ visitorId) 1 + + -- print all visitors + allVisitors <- get (Visitors today) + print allVisitors +``` + +Using operator `(:/)`, we could write `Visitors today :/ visitorId` +to reference a single field of a hash. However, we can also +retrieve and print the whole hash if we choose to. + +#### Aside: Hashes vs. composite keys + +In the previous example, the reference `Visitors date` +points to a `Map VisitorId Int`. This is one realisation of a mapping +`(Date, VisitorId) -> Int` but not the only possible one. +Another way would be including the `VisitorId` in the key like this: + +```haskell +data VisitCount = VisitCount Date VisitorId + +instance Redis.Ref VisitCount where + type ValueType VisitCount = Int + + toIdentifier (VisitCount date visitorId) = + Redis.colonSep + [ "visitors" + , ByteString.pack (show date) + , ByteString.pack (show visitorId) + ] +``` + +This way, every date-visitor combination gets its own full key-value entry +in Redis. There are advantages and disadvantages to either representation. + +* With hashes, you also implicitly get a list of visitor IDs for each day. + With composite keys, you have to use the `SCAN` or `KEYS` Redis command. + +* It's easy to `get`, `set` or `take` whole hashes (atomically). + With separate keys, you have to use an explicit transaction, + and code up these operations manually. + +* Hashes take less space than the same number of values in separate keys. + +* You cannot set the TTL of items in a hash separately: only the whole hash has a TTL. + With separate keys, you can set TTL individually. + +* You cannot have complex data types (Redis sets, Redis hashes, etc.) + nested inside hashes without encoding them as `ByteString`s first. + (See [Lists, sets, hashes, etc.](#lists-sets-hashes-etc)) + There are no such restrictions for separate keys. + +Hence the encoding depends on your use case. If you're caching +a set of related things for a certain visitor, which you want to read as a whole +and expire as a whole, it makes sense to put them in a hash. + +If your items are rather separate, you want to expire them separately, +or you want to store structures like hashes inside, +you have to put them in separate keys. +Fields like `date` should probably generally go in the (possibly composite) key +because they will likely affect the required expiration time. + +### Records + +We have just seen how to use Redis hashes to store values of type `Map k v`. +The number of items in the map is unlimited +but all keys and values must have the same type. + +There's another (major) use case for Redis hashes: records. +Records are structures which contain a fixed number of named values, +where each value can have a different type. +It is therefore a natural way of clustering related data together. + +Here's an example showing how records are modelled in `redis-schema`. + +```haskell +-- First, we use GADTs to describe the available fields and their types. +-- Here, 'Email' has type 'Text', 'DateOfBirth' has type 'Date', +-- and 'Visits' and 'Clicks' have type 'Int'. +data VisitorField :: * -> * where + Email :: VisitorField Text + DateOfBirth :: VisitorField Date + Visits :: VisitorField Int + Clicks :: VisitorField Int + +-- We define how to translate record keys to strings +-- that will be used to key the Redis hash. +instance Redis.RecordField VisitorField where + rfToBS Email = "email" + rfToBS DateOfBirth = "date-of-birth" + rfToBS Visits = "visits" + rfToBS Clicks = "clicks" + +-- Then we define the type of references pointing to the visitor statistics +-- for any given visitor ID. +data VisitorStats = VisitorStats VisitorId + +-- Finally, we declare that the type of references is indeed a Redis reference. +instance Redis.Ref VisitorStats where + -- The type pointed to is 'Redis.Record VisitorField', which means + -- a record with the fields defined by 'VisitorField'. + type ValueType VisitorStats = Redis.Record VisitorField + + -- As usual, this defines what key in Redis this reference points to. + toIdentifier (VisitorStats visitorId) = + Redis.colonSep ["visitors", "statistics", Redis.toBS visitorId] +``` + +This example is a bit silly because if you know `DateOfBirth` about your unregistered visitors, +there's something very wrong. However, for demonstrational purposes, it'll suffice. + +Now we can get references to the individual fields with the specialised operator `:.`. + +```haskell +handleClick :: VisitorId -> Redis () +handleClick visitorId = do + -- for demonstration purposes, log the email + email <- Redis.get (VisitorStats visitorId :. Email) + liftIO $ print email + + -- atomically increase the counter of clicks + Redis.incrementBy (VisitorStats visitorId :. Clicks) 1 +``` + +In the current implementation, `Record`s cannot be read or written as a whole. +(However, they *can* be deleted and their TTL can be set.) +There is no special reason for that, except that it would be too much type-level code +that we currently do not need, so we keep it simple. + +However, see [Meta-records](#meta-records) for the next best solution. + +#### Aside: non-fixed record fields + +The number of fields in a record is not *really* fixed. +Consider the following declaration. + +```haskell +data VisitorField :: * -> * where + Visits :: Date -> VisitorField Int + +instance Redis.RecordField VisitorField where + rfToBS (Visits date) = Redis.colonSep ["visits", Redis.toBS date] +``` + +This creates a record with a separate field for every date: + +```haskell +handleVisit :: VisitorId -> Date -> Redis () +handleVisit visitorId today = do + Redis.incrementBy (VisitorStats visitorId :. Visits today) 1 +``` + +### Transactions + +Redis does support transactions and `redis-schema` supports them, +but they are not like SQL transactions, which you may be accustomed to. +A more suggestive name for Redis transactions might be +"[mostly](#errors-in-transactions) atomic operation batches". + +The main difference between SQL-like transactions and batched Redis transactions +is that in SQL, you can start a transaction, run a query, receive its output, +and then run another query in the same transaction. Sending queries and receiving their outputs +can be interleaved in the same transaction, and later queries can depend on the output +of previous queries, while the database takes care of the ACIDity of the transaction. + +With Redis-style batched transactions, on the other hand, you can batch up +multiple operations but the atomicity of a transaction ends at the moment you +receive the output of those operations. Anything you do with the output is not +enclosed in that transaction anymore, and other clients could have modified the +data in the meantime. In other words, later operations in a batched transaction +cannot depend on the output of the previous operations, as that output is not +available yet. + +While the structure of SQL-like transactions is captured by the `Monad` typeclass, +Redis-style fixed-effects transactions are described by `Applicative` functors -- +and this is exactly the interface that `redis-schema` provides for Redis transactions. + +#### The `Tx` functor + +`redis-schema` defines the `Tx` functor for transactional computations. + +```haskell +newtype Tx inst a +instance Functor (Tx inst) +instance Applicative (Tx inst) +instance Alternative (Tx inst) + +atomically :: Tx inst a -> RedisM inst a +txThrow :: RedisException -> Tx inst a +``` + +The type parameter `inst` is explained in section [Redis instances](#redis-instances), +but can be ignored for now. + +Redis transactions are run using the combinator called `atomically`. +A failing operation (or using `txThrow`) +in a transaction [will not prevent any other side effects from taking place](#errors-in-transactions); +only the exception will be re-thrown in the `RedisM` monad +instead of returning the output of the transaction. The `Alternative` instance +of `Tx` can be used to address exceptions. + +#### Working with transactions + +Most functions, like `get`, `set` or `take`, +have a sibling that can be used in a transaction, usually prefixed with `tx`: + +```haskell +get :: Ref ref => ref -> RedisM (RefInstance ref) (Maybe (ValueType ref)) +txGet :: Ref ref => ref -> Tx (RefInstance ref) (Maybe (ValueType ref)) +``` + +With `ApplicativeDo`, these transactional functions can be used as conveniently +as their non-transactional counterparts. For example, the function `take`, +which atomically reads and deletes a Redis value, could be (re-)implemented as follows: + +```haskell +{-# LANGUAGE ApplicativeDo #-} + +take :: Ref ref => ref -> RedisM (RefInstance ref) (Maybe (ValueType ref)) +take ref = atomically $ do + value <- txGet ref + txDelete_ ref + pure value +``` + +#### What Redis transactions cannot do + +One might try to attempt an alternative implementation of `txIncrementBy`: + +```haskell +import Data.Maybe (fromMaybe) + +txIncrementBy' :: (SimpleRef ref, Num (ValueType ref)) + => ref -> Integer -> Tx (RefInstance ref) (ValueType ref) +txIncrementBy' ref incr = do + oldValue <- fromMaybe 0 <$> txGet ref -- COMPILER ERROR + let newValue = oldValue + fromInteger incr + txSet ref newValue + pure newValue +``` + +The compiler complains +``` +• Could not deduce (Monad (Tx (RefInstance ref))) + arising from a do statement +``` +because `oldValue` is used non-trivially in the `do` block, +but `Tx` implements only `Applicative` and not `Monad`. + +This error is exactly a goal of the design: it indicates at compile time +that Redis does not support this usage pattern. + +#### Errors in transactions + +Beware that Redis won't roll back failed transactions, which means they +are not atomic in that sense, and may be carried out incompletely. +A Redis transaction that fails in the middle +will keep going and retain all effects except for any failed operations. +See [the Redis documentation](https://redis.io/docs/manual/transactions/#errors-inside-a-transaction) +for details and rationale. + +#### Monads vs applicative functors + +The underlying library of `redis-schema`, Hedis, provides a monad `RedisTx` +to describe Redis transactions. Since monads would be too powerful, Hedis uses +an opaque wrapper for `Queued` results to prevent the users from accessing +values that are not available yet. We believe that using an applicative functor +instead is a perfect match for this use case: it allows exactly the right +operations, and all wrapping/unwrapping can be done entirely transparently. +`Tx` also propagates exceptions from transactions transparently. + +### Exceptions + +The type of exceptions in `redis-schema` is `RedisException`, +and they are thrown using `throwIO` under the hood. +These arise mostly from internal error conditions, such as +connection errors, decoding errors, etc., +but library users can nevertheless still throw them manually +using `throw :: RedisException -> RedisM inst a`. + +Unlike `hedis`, `redis-schema` does support throwing exceptions +in transactions. Exceptions do *not* abort transactions +-- all effects of a transaction will persist even if an exception has been thrown -- +but `RedisException`s thrown using `txThrow` are transparently propagated out of the transaction +and thrown at the `RedisM` level instead of returning the result of the transaction. + +### Custom data types + +Every type that can be stored in Redis using `redis-schema` +comes with a `Value` instance that describes how to read, write, and perform +other operations on values of that type in Redis. + +There are two kinds of Redis `Value`s: simple values and non-simple values. +Simple values are those that encode/decode to/from a `ByteString`, and thus +have no restrictions on how they can be used in Redis. +They can be stored in top-level keys, as well as in Redis lists, +Redis sets, Redis hashes, etc. Simple values include +integers, floats, text, bytestrings, etc. + +Non-simple values are all values that are more complicated than a bytestring, +and thus will come with restrictions. For example, Redis lists are not simple values. + +Let's start by discussing simple values. + +#### Simple values + +The easiest case of declaring Redis instances for custom data types +are newtypes of types that already have Redis instances. For example, +if your user IDs are textual but you would still like to keep them apart +from other `Text` data, you could use the following declarations. + +```haskell +{-# LANGUAGE DerivingStrategies #-} + +newtype UserId = UserId Text + deriving newtype (Redis.Serializable) + +instance Redis.Value inst UserId +instance Redis.SimpleValue inst UserId +``` + +Thanks to `deriving newtype`, we did not have to write +any wrapping/unwrapping boilerplate, and thanks to +the default implementations of `Value` methods, +we did not have to write those, either. + +The class `SimpleValue` does not have any methods, and it mostly +only stands for the list of constraints in its declaration +(primarily, for the `Serializable` constraint). +`SimpleValue` is a typeclass rather than a constraint alias +because you may want to have a `Serializable` instance for +a non-simple `Value`. Thus a `SimpleValue` instance also represents +the intentional declaration that the type in question should be regarded +as a simple value. + +For other types, we need to supply a `Serializable` instance, +which is, however, often not too hard. + +```haskell +data Color = Red | Green | Blue + +instance Redis.Serializable Color where + fromBS = Redis.readBS + toBS = Redis.showBS + +-- Convenience functions available: +-- Redis.readBS :: Read val => ByteString -> Maybe val +-- Redis.showBS :: Show val => val -> ByteString + +instance Redis.Value inst Color +instance Redis.SimpleValue inst Color +``` + +The typeclass `Serializable` is separate from `Show`, `Read`, and `Binary` because: +* `Show` and `Read` quote strings, and we need the ability to avoid doing it +* `Binary` does not produce human-readable output and would thus affect the usability of tools like `redis-cli` + +Since `redis-schema` is intended to be imported qualified as `Redis`, +`Redis.Serializable` is an accurate name for the typeclass. + +#### Non-simple values + +Non-simple values have instances only for `Value`. +The default implementations of methods of `Value` require a `SimpleValue` instance, +thus relieving us from defining them whenever a `SimpleValue` instance exists. +For non-simple values, we have to implement the methods of `Value` manually. + +Not all methods of `Value` may make sense for all data types, +or not all methods may be practically implementable. +In such cases, it's acceptable to fill the definition with an `error` message. + +For example, the `Record` type defined by `redis-schema` does not support +reading/writing whole records because that would require more type-level +machinery than we needed at the time. + +Another example is the fact that `setTTL` does not make (a lot of) +sense for values represented by `SviHash`, +i.e. for values that exist inside a Redis hash, as TTL can be set only for the whole hash. +Pragmatically, `redis-schema` resorts to silently changing the TTL for the whole hash. + +Yet another example are the `PubSub` channels, +where the operations of `get` and `set` do not make sense. + +In all these cases, the "correct" solution would be splitting the `Value` +typeclass into smaller classes per supported feature so that the availability +of the individual operations is declared at the type level. We decided to keep +things simple (if perhaps a bit crude) and use a single `Value` typeclass. This +may be revisited in the future. + +#### Redis instances + +In section [Simple Variables](#simple-variables), we have seen that +a `Redis.Ref` determines a "path to a variable" in Redis. +But what if you run more Redis servers? You might want that to use different +key eviction policies and different memory limits for different purposes. + +The definition of `Redis.Ref` includes an extra associated type family +called `RefInstance`, which identifies the server, representing the hitherto +missing part of the "path to the variable". This type family has a default +value `DefaultInstance`, which is why we have not needed to deal with it so far. +Here's what it looks like: + +```haskell +-- | The kind of Redis instances. Ideally, this would be a user-defined DataKind, +-- but since Haskell does not have implicit arguments, +-- that would require that we index everything with it explicitly, +-- which would create a lot of syntactic noise. +-- +-- (Ab)using the * kind for instances is a compromise. +type Instance = * + +-- | We also define a default instance. +-- This is convenient for code bases using only one Redis instance, +-- since 'RefInstance' defaults to this. (See the 'Ref' typeclass below.) +data DefaultInstance + +-- | The Redis monad related to the default instance. +type Redis = RedisM DefaultInstance + +class Value (RefInstance ref) (ValueType ref) => Ref ref where + -- | Type of the value that this ref points to. + type ValueType ref :: * + + -- | RedisM instance this ref points into, with a default. + type RefInstance ref :: Instance + type RefInstance ref = DefaultInstance + + -- | How to convert the ref to an identifier that its value accepts. + toIdentifier :: ref -> Identifier (ValueType ref) +``` + +A Redis instance can be added by declaring an empty tag type, +for example as follows: + +```haskell +-- For data that should not get lost +type InstReliable = Redis.DefaultInstance + +-- For throwaway data to speed things up +data InstCacheLRU +``` + +Then a `Redis.Ref` can be placed in the appropriate Redis instance: +```haskell +data VisitorCount = VisitorCount + +instance Redis.Ref VisitorCount where + type ValueType VisitorCount = Integer + type RefInstance VisitorCount = InstReliable -- reliable + toIdentifier VisitorCount = "visitor_count" + + +data CachedFile = CachedFile FilePath + +instance Redis.Ref CachedFile where + type ValueType CachedFile = ByteString + type RefInstance CachedFile = InstCacheLRU -- evicted as necessary + toIdentifier (CachedFile path) = Redis.colonSep ["cached_files", BS.pack path] +``` + +Finally, all connections and the Redis monad are tagged +by the Redis instance, best illustrated by this type signature: + +```haskell +run :: MonadIO m => Pool inst -> RedisM inst a -> m a +``` + +There are two consequences. +First, all operations in a `RedisM` computation must work with the same instance. +Second, it is practical to have a wrapper function around `run` that automatically +selects the right connection `Pool` from the environment, based on the Redis instance +specified in the type of the `RedisM` computation. + +### Meta-records + +In Haskell, records can be nested arbitrarily. You can have a record +that contains some fields alongside another couple of records, +which themselves contain arbitrarily nested maps and lists of further records. + +Redis does not support such arbitrary nesting while being able to +access and manipulate the inner structures like you would a top-level one +(e.g. increment a counter deep in the structure). +However, we can often work around this limitation +by distributing the datastructure over a number of separate Redis keys. +For example, consider a case where each visitor should be associated with +the number of visits, the number of clicks, and the set of their favourite songs. +Here we can keep the visits+clicks in one record reference per visitor, and the set of favourites +in another reference, again per visitor. +However, we still need to read the visits+clicks separately from the favourites. +This is not just an impediment to convenience: two separate reads may lead to a race condition, +unless we run them in a transaction. + +Since `redis-schema` encourages compositionality, it is possible to make data structures +that gather (or scatter) all their data across Redis automatically, without having +to manipulate every component separately every time. Here's an example. + +```haskell +-- VisitorFields are visits and clicks. +data VisitorField :: * -> * where + Visits :: VisitorField Int + Clicks :: VisitorField Int + +-- VisitorStats is a record with VisitorFields +data VisitorStats = VisitorStats VisitorId +instance Redis.Ref VisitorStats where + type ValueType VisitorStats = Redis.Record VisitorField + toIdentifier = {- ...omitted... -} + +-- A separate reference to the favourite songs. +data FavouriteSongs = FavouriteSongs VisitorId +instance Redis.Ref FavouriteSongs where + type ValueType FavouriteSongs = Set SongId + toIdentifier = {- ...omitted... -} + +-- Finally, here's our composite record that we want to read/write atomically. +data VisitorInfo = VisitorInfo + { viVisits :: Int + , viClicks :: Int + , viFavouriteSongs :: Set SongId + } + +instance Redis.Value Redis.DefaultInstance VisitorInfo where + type Identifier VisitorInfo = VisitorId + + txValGet visitorId = do + visits <- fromMaybe 0 <$> Redis.txGet (VisitorStats visitorId :. Visits) + clicks <- fromMaybe 0 <$> Redis.txGet (VisitorStats visitorId :. Clicks) + favourites <- fromMaybe Set.empty <$> Redis.txGet (FavouriteSongs visitorId) + return $ Just VisitorInfo + { viVisits = visits + , viClicks = clicks + , viFavourites = favourites + } + + txValSet visitorId vi = do + Redis.txSet (VisitorStats visitorId :. Visits) (viVisits vi) + Redis.txSet (VisitorStats visitorId :. Clicks) (viClicks vi) + Redis.txSet (FavouriteSongs visitorId) (viFavourites vi) + + txValDelete visitorId = do + Redis.txDelete (VisitorStats visitorId) + Redis.txDelete (FavouriteSongs visitorId) + + {- etc. -} +``` + +It's a bit of a boilerplate, but now all the scatter/gather code is packed +in the `Value` instance, it's safe and it composes. Moreover, using `let`-bound +shorthand functions for common expressions, the repetition can be greatly minimised. + +#### Aside: references + +A reference to `VisitorInfo` would look as follows. +```haskell +data VisitorInfoRef = VisitorInfoFor VisitorId + +instance Redis.Ref VisitorInfoRef where + type ValueType VisitorInfoRef = VisitorInfo + toIdentifier (VisitorInfoFor visitorId) = visitorId +``` + +Meta-records demonstrate why reference ADTs are more flexible than bytestring keys. +Since `VisitorInfo` is identified by `VisitorId`, as determined by the associated +type family `Identifier`, it would be impractical to extract `VisitorId` +from a `ByteString` reference. + +More fundamentally, a meta-record is not associated with any single +key in Redis so there is no bytestring key to speak of -- and that's why +we used `VisitorId` to identify the meta-record above instead. + +We *could* approach the bytestring as the prefix of all keys that constitute the meta-record +but that's less flexible than the ADT approach, which lets us extract +the components of the key and rearrange them as we see fit. +The optimal arrangement of data in Redis may not coincide with a single +fixed bytestring key prefix. + +#### Aside: instances + +Looking back at this instance head: +```haskell +instance Redis.Value Redis.DefaultInstance VisitorInfo where +``` +We see that unlike in the usual case, this `Value` instance has been declared specifically +for `DefaultInstance`. The reason is that the definition of the `Value` instance +for `VisitorInfo` accesses Redis refs `VisitorStats` and `FavouriteSongs`, +and these refs are linked to `DefaultInstance`. + +Since every Redis `Ref` must be linked to a specific Redis instance, and cannot be polymorphic +in the instance (its purpose is to give a path to the variable, as discussed), +all meta-records that access them under the hood must be declared for that particular instance. +Consequently, all `Ref`s that make up a meta-record must be linked to the same Redis instance. + +## Libraries + +### Locks + +Locks are implemented in `Database.Redis.Schema.Lock`. +The basic type is the exclusive lock; the shared lock is implemented using an exclusive lock. +Hence the shared lock is also slower, and it's sometimes better to use an exclusive lock, +even though a shared lock would be sufficient. + +The library does not export much API; the main points of interest +are functions `withExclusiveLock` and `withShareableLock`, which bracket +a synchronised operation. +```haskell +withExclusiveLock :: + ( MonadCatch m, MonadThrow m, MonadMask m, MonadIO m + , Redis.Ref ref, Redis.ValueType ref ~ ExclusiveLock + ) + => Redis.Pool (Redis.RefInstance ref) + -> LockParams -- ^ Params of the lock, such as timeouts or TTL. + -> ref -- ^ Lock ref + -> m a -- ^ The action to perform under lock + -> m a +``` + +Another purpose of `Database.Redis.Schema.Lock` is to demonstrate +how a library can be implemented on top of `Database.Redis.Schema`. + +### Remote jobs + +Sadly, this library has not been published yet. +We'd like to, though. + +## Future work + +* Reading numeric types in Redis never returns `Nothing`; they'll return `Just 0` instead. + Perhaps the return types could reflect that somehow. + +* Different Redis `Value`s sometimes support different operations, as briefly discussed + at [non-simple values](#non-simple-values). We may want to split `Value` into multiple + type classes, depending on the supported operations. + +* [Records](#records) cannot be read/written as a whole. + The only reason is that we did not need it, + and thus opted to avoid all the type-level machinery + coming with extensible records. + However, adopting an established library like `vinyl` + as an optional dependency might be worth it. + +## License + +BSD 3-clause. + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/redis-schema.cabal b/redis-schema.cabal new file mode 100644 --- /dev/null +++ b/redis-schema.cabal @@ -0,0 +1,54 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.7. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 8ad979f047b1d31267791ddddc75577141d0b1f972f265c586894ab5f99c498c + +name: redis-schema +version: 0.1.0 +synopsis: Typed, schema-based, composable Redis library +description: Typed, schema-based, composable Redis library +category: Database +homepage: https://github.com/chordify/redis-schema#readme +bug-reports: https://github.com/chordify/redis-schema/issues +author: Chordify B.V. +maintainer: haskelldevelopers@chordify.net +copyright: 2022 Chordify B.V. +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/chordify/redis-schema + +library + exposed-modules: + Database.Redis.Schema + Database.Redis.Schema.Lock + other-modules: + Paths_redis_schema + hs-source-dirs: + src + default-extensions: + OverloadedStrings + ghc-options: -Wall + build-depends: + base >=4.7 && <5 + , binary + , bytestring + , containers + , exceptions + , hedis + , mtl + , numeric-limits + , random + , text + , time + , uuid + default-language: Haskell2010 diff --git a/src/Database/Redis/Schema.hs b/src/Database/Redis/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Database/Redis/Schema.hs @@ -0,0 +1,1244 @@ +{-# LANGUAGE Strict #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} -- for (RefInstance ref) in constraints in instance head +{-# OPTIONS_GHC -fno-warn-orphans #-} -- for Hedis.RedisResult (a,b,c) + +-- | The schema-based Redis module. +-- This module is intended to be imported qualified. +-- That's why we don't have 'RedisRef' but rather 'Redis.Ref'. +module Database.Redis.Schema + ( Pool(..), RedisM(..) + -- Pool and RedisM export their internals so other libraries can provide combinators + -- like runNonBlocking or others. These internals are not meant to be used ordinarily. + , Redis, Instance, DefaultInstance + , Tx, atomically, runTx + , RedisException(..) + , Ref(..), Value(..) + , SimpleRef, SimpleValue, SimpleValueIdentifier(..), Serializable(..), Serializables(..) + , TTL(..) + , run + , connect + , incrementBy, incrementByFloat + , txIncrementBy + , get, set, getSet + , txGet, txSet, txExpect + , setWithTTL, setIfNotExists, setIfNotExists_ + , txSetWithTTL, txSetIfNotExists, txSetIfNotExists_ + , delete_, txDelete_ + , Database.Redis.Schema.take, txTake + , setTTL, setTTLIfExists, setTTLIfExists_ + , txSetTTL, txSetTTLIfExists, txSetTTLIfExists_ + , readBS, showBS + , showBinary, readBinary, colonSep + , Tuple(..) + , day, hour, minute, second + , throw, throwMsg + , sInsert, sDelete, sContains, sSize + , Priority(..), zInsert, zSize, zCount, zDelete, zPopMin, bzPopMin, zRangeByScoreLimit + , txSInsert, txSDelete, txSContains, txSSize + , MapItem(..) + , RecordField(..), RecordItem(..), Record + , lLength, lAppend, txLAppend, lPushLeft, lPopRight, lPopRightBlocking, lRem + , watch, unwatch + , unliftIO + , deleteIfEqual, setIfNotExistsTTL + , PubSub, pubSubListen, pubSubCountSubs + ) where + +import GHC.Word ( Word32 ) +import Data.Functor ( void, (<&>) ) +import Data.Function ( (&) ) +import Data.Time ( UTCTime, LocalTime, Day ) +import Text.Read ( readMaybe ) +import Data.ByteString ( ByteString ) +import Data.Binary ( Binary, encode, decodeOrFail ) +import Data.Text ( Text ) +import Data.Text.Encoding ( encodeUtf8, decodeUtf8 ) +import Data.Kind ( Type ) +import Data.Map ( Map ) +import Data.Set ( Set ) +import Data.Int ( Int64 ) +import Data.UUID ( UUID ) +import qualified Data.UUID as UUID + +import Control.Applicative +import qualified Control.Arrow as Arrow +import Control.Monad ( (<=<) ) +import Control.Exception ( throwIO, Exception ) +import Control.Monad.Reader ( runReaderT, ask ) +import Control.Monad.IO.Class ( liftIO, MonadIO ) + +import qualified Numeric.Limits +import qualified Database.Redis as Hedis +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified System.IO.Error as IOE + +-- | Each instance has a distinct connection pool type. +-- (Hedis names it Connection but it's a pool.) +newtype Pool inst = Pool{_unPool :: Hedis.Connection} + +-- | Instance-indexed monad for Redis computations. +newtype RedisM inst a = Redis{unRedis :: Hedis.Redis a} + deriving newtype (Functor, Applicative, Monad, MonadIO, Hedis.MonadRedis) + +-- | The kind of Redis instances. Ideally, this would be a user-defined DataKind, +-- but since Haskell does not have implicit arguments, +-- that would require that we index everything with it explicitly, +-- which would create a lot of syntactic noise. +-- +-- (Ab)using the Type kind for instances is a compromise. +type Instance = Type + +-- | We also define a default instance. +-- This is convenient for code bases using only one Redis instance, +-- since 'RefInstance' defaults to this. (See the 'Ref' typeclass below.) +data DefaultInstance + +-- | The Redis monad related to the default instance. +type Redis = RedisM DefaultInstance + +instance Hedis.RedisCtx (RedisM inst) (Either Hedis.Reply) where + returnDecode = Redis . Hedis.returnDecode + +data RedisException + = BadConnectionString String String + | CouldNotPing String + | UnexpectedResult String String + | UserException String + | TransactionAborted + | TransactionError String + | CouldNotDecodeValue (Maybe ByteString) + | LockAcquireTimeout + | UnexpectedStatus String Hedis.Status + | EmptyAlternative -- for 'instance Alternative Tx' + deriving (Show, Exception) + +-- | Time-To-Live for Redis values. The Num instance works in (integral) seconds. +newtype TTL = TTLSec { ttlToSeconds :: Integer } + deriving newtype (Eq, Ord, Num) + +run :: MonadIO m => Pool inst -> RedisM inst a -> m a +run (Pool pool) = liftIO . Hedis.runRedis pool . unRedis + +throw :: RedisException -> RedisM inst a +throw = liftIO . throwIO + +throwMsg :: String -> RedisM inst a +throwMsg = throw . UserException + +-- | Expect Right, otherwise throw UnexpectedResult. +expectRight :: Show e => String -> Either e a -> RedisM inst a +expectRight _msg (Right x) = pure x +expectRight msg (Left e) = throw $ UnexpectedResult ("Redis.expectRight: " ++ msg) (show $ left e) + where + -- hard to give this type to Left inline + left :: e -> Either e () + left = Left + +-- | Expect transaction success, otherwise throw. +expectTxSuccess :: Hedis.TxResult a -> RedisM inst a +expectTxSuccess (Hedis.TxSuccess x) = pure x +expectTxSuccess Hedis.TxAborted = throw TransactionAborted +expectTxSuccess (Hedis.TxError err) = throw $ TransactionError err + +-- | Expect exact value, otherwise throw UnexpectedResult. +expect :: (Eq a, Show a) => String -> a -> a -> RedisM inst () +expect msg expected actual + | expected == actual = pure () + | otherwise = throw $ UnexpectedResult ("Redis.expect: " ++ msg) (show actual) + +-- Useful in combination with the expect* functions. +ignore :: a -> RedisM inst () +ignore _ = pure () + +-- | Open a connection pool to redis +connect :: String -> Int -> IO (Pool inst) +connect connectionString poolSize = + case Hedis.parseConnectInfo connectionString of + Left err -> throwIO $ BadConnectionString connectionString err + Right connInfo -> do + pool <- Hedis.connect connInfo + { Hedis.connectMaxConnections = poolSize + } + customizeIOError connectionString (Hedis.runRedis pool Hedis.ping) >>= \case + Right Hedis.Pong -> return (Pool pool) + resp -> throwIO $ CouldNotPing (show resp) + where + -- Runs an IO action and prepends a custom error message to any occuring IOError + customizeIOError :: String -> IO a -> IO a + customizeIOError errorMessage action = IOE.modifyIOError customError action + where + customError :: IOError -> IOError + customError err = IOE.ioeSetErrorString err (errorMessage <> "; " <> IOE.ioeGetErrorString err) + +-- | Redis transactions. +-- +-- In comparison with Hedis transactions: +-- +-- * 'Tx' is newtyped as a separate functor for clearer types and better error messages. +-- +-- * 'Tx' is not a monad, just an 'Applicative' functor. +-- Applicative exactly corresponds to the nature of Redis transactions, +-- and does not need 'Queued' hacks. +-- +-- * 'Tx' supports throwing, and catching via 'Alternative'. +-- Beware that 'Tx' is 'Applicative' so all side effects will be carried out, +-- whether any actions throw or not. Throwing and catching is done at the level +-- where the _results_ of the individual applicative actions are composed. +-- +-- You can still have do-notation with the @ApplicativeDo@ extension. +newtype Tx inst a = Tx + { unTx :: Hedis.RedisTx (Hedis.Queued (Either RedisException a)) + } + +instance Functor (Tx inst) where + fmap f (Tx tx) = Tx $ fmap (fmap (fmap f)) tx + +instance Applicative (Tx inst) where + pure x = Tx $ pure (pure (pure x)) + Tx txF <*> Tx txX = Tx $ do + queuedF <- txF + queuedX <- txX + pure $ do + eitherF <- queuedF + eitherX <- queuedX + pure (eitherF <*> eitherX) + +instance Alternative (Tx inst) where + empty = txThrow EmptyAlternative + Tx txX <|> Tx txY = Tx $ do + queuedX <- txX + queuedY <- txY + pure $ do + eitherX <- queuedX + eitherY <- queuedY + pure $ case eitherX of + Right x -> Right x + Left _err -> case eitherY of + Right y -> Right y + Left err -> Left err + +-- | Run a Redis transaction and return its result. +-- +-- Most code will probably want to use 'atomically' instead, +-- which automatically propagates errors. +runTx :: Tx inst a -> RedisM inst (Hedis.TxResult (Either RedisException a)) +runTx = Redis . Hedis.multiExec . unTx + +-- | Throw in a transaction. +txThrow :: RedisException -> Tx inst a +txThrow e = Tx $ pure (pure (Left e)) + +-- | Embed a raw Hedis action in a 'Tx' transaction. +txWrap :: Hedis.RedisTx (Hedis.Queued a) -> Tx inst a +txWrap action = Tx (fmap Right <$> action) + +-- | Run a 'Tx' transaction, propagating any errors. +atomically :: Tx inst a -> RedisM inst a +atomically tx = runTx tx >>= expectTxSuccess >>= \case + Right x -> pure x + Left e -> throw e + +-- | Apply a possibly failing computation to the result of a transaction. +-- +-- Useful for implementation of various checks. +txCheckMap :: (a -> Either RedisException b) -> Tx inst a -> Tx inst b +txCheckMap f (Tx tx) = Tx (fmap (fmap g) tx) + where + g (Left e) = Left e -- we already had an error here + g (Right x) = f x -- possibly fail + +-- | Expect an exact value. +txExpect :: (Eq a, Show a) => String -> a -> Tx inst a -> Tx inst () +txExpect msg expected = void . txCheckMap f + where + f x | x == expected = Right x + | otherwise = Left $ UnexpectedResult msg (show x) + +-- | Reference to some abstract Redis value. +-- +-- 'ByteString's are inappropriate for this purpose: +-- +-- * 'Ref's are typed. +-- +-- * bytestring concatenation and other faffing is ugly and error-prone. +-- +-- * some values may be stored across several Redis keys, +-- (such as Tiers.Redis.Profile), +-- in which case bytestrings are not even sufficient. +-- +-- All methods have defaults for easy implementation of 'SimpleValue's for new types. +-- For simple values, it's sufficient to implement (or newtype-derive) 'SimpleValue', +-- and declare an empty @instance Value @. +class Value (RefInstance ref) (ValueType ref) => Ref ref where + -- | Type of the value that this ref points to. + type ValueType ref :: Type + + -- | RedisM instance this ref points into, with a default. + type RefInstance ref :: Instance + type RefInstance ref = DefaultInstance + + -- | How to convert the ref to an identifier that its value accepts. + toIdentifier :: ref -> Identifier (ValueType ref) + +-- | Type that can be read/written from Redis. +-- +-- This can be a simple value, such as string or integer, or a composite value, +-- such as a complex record stored across multiple keys, hashes, sets and lists. +-- +-- We parameterise the typeclass with the Redis instance. +-- Most Value instances will want to keep 'inst' open +-- but some may need to restrict it to a particular Redis instance; +-- especially those that access Refs under the hood, since Refs are instance-specific. +class Value inst val where + -- | How the value is identified in Redis. + -- + -- Types like hashes, sets or list are always top-level keys in Redis, + -- so these are identified by bytestrings. Simple values can be top-level + -- or hash fields, so they are identified by SimpleValueIdentifier. + -- Complex values may be identified by something else; for example + -- 'Tiers.Redis.Profile' is identified by a 'Tiers.Token', + -- because it's a complex value spread across multiple Redis keys. + type Identifier val :: Type + type Identifier val = SimpleValueIdentifier -- default + + + -- | Read a value from Redis in a transaction. + txValGet :: Identifier val -> Tx inst (Maybe val) + + default txValGet :: SimpleValue inst val => Identifier val -> Tx inst (Maybe val) + txValGet (SviTopLevel keyBS) = fmap (fromBS =<<) . txWrap $ Hedis.get keyBS + txValGet (SviHash keyBS hkeyBS) = fmap (fromBS =<<) . txWrap $ Hedis.hget keyBS hkeyBS + + -- | Write a value to Redis in a transaction. + txValSet :: Identifier val -> val -> Tx inst () + + default txValSet :: SimpleValue inst val => Identifier val -> val -> Tx inst () + txValSet (SviTopLevel keyBS) val = + txExpect "txValSet/plain" Hedis.Ok + $ txWrap (Hedis.set keyBS $ toBS val) + txValSet (SviHash keyBS hkeyBS) val = + void + $ txWrap (Hedis.hset keyBS hkeyBS $ toBS val) + + -- | Delete a value from Redis in a transaction. + txValDelete :: Identifier val -> Tx inst () + + default txValDelete :: SimpleValue inst val => Identifier val -> Tx inst () + txValDelete (SviTopLevel keyBS) = void . txWrap $ Hedis.del [keyBS] + txValDelete (SviHash keyBS hkeyBS) = void . txWrap $ Hedis.hdel keyBS [hkeyBS] + + -- | Set time-to-live for a value in a transaction. Return 'True' if the value exists. + txValSetTTLIfExists :: Identifier val -> TTL -> Tx inst Bool + + default txValSetTTLIfExists :: SimpleValue inst val => Identifier val -> TTL -> Tx inst Bool + txValSetTTLIfExists (SviTopLevel keyBS) (TTLSec ttlSec) = + txWrap $ Hedis.expire keyBS ttlSec + txValSetTTLIfExists (SviHash keyBS _hkeyBS) (TTLSec ttlSec) = + txWrap $ Hedis.expire keyBS ttlSec + + + -- | Read a value. + valGet :: Identifier val -> RedisM inst (Maybe val) + + default valGet :: SimpleValue inst val => Identifier val -> RedisM inst (Maybe val) + valGet (SviTopLevel keyBS) = + fmap (fromBS =<<) . expectRight "valGet/plain" =<< Hedis.get keyBS + valGet (SviHash keyBS hkeyBS) = + fmap (fromBS =<<) . expectRight "valGet/hash" =<< Hedis.hget keyBS hkeyBS + + -- | Write a value. + valSet :: Identifier val -> val -> RedisM inst () + + default valSet :: SimpleValue inst val => Identifier val -> val -> RedisM inst () + valSet (SviTopLevel keyBS) val = + expect "valSet/plain" (Right Hedis.Ok) =<< Hedis.set keyBS (toBS val) + valSet (SviHash keyBS hkeyBS) val = + ignore {- @Integer -} =<< expectRight "valSet/hash" =<< Hedis.hset keyBS hkeyBS (toBS val) + -- ^- this is Bool in some versions of Hedis and Integer in others + + -- | Delete a value. + valDelete :: Identifier val -> RedisM inst () + + default valDelete :: SimpleValue inst val => Identifier val -> RedisM inst () + valDelete (SviTopLevel keyBS) = + ignore @Integer =<< expectRight "valDelete/plain" =<< Hedis.del [keyBS] + valDelete (SviHash keyBS hkeyBS) = + ignore @Integer =<< expectRight "valDelete/hash" =<< Hedis.hdel keyBS [hkeyBS] + + -- | Set time-to-live for a value. Return 'True' if the value exists. + valSetTTLIfExists :: Identifier val -> TTL -> RedisM inst Bool + + default valSetTTLIfExists :: SimpleValue inst val => Identifier val -> TTL -> RedisM inst Bool + valSetTTLIfExists (SviTopLevel keyBS) (TTLSec ttlSec) = + expectRight "valSetTTLIfExists/plain" =<< Hedis.expire keyBS ttlSec + valSetTTLIfExists (SviHash keyBS _hkeyBS) (TTLSec ttlSec) = + expectRight "valSetTTLIfExists/hash" =<< Hedis.expire keyBS ttlSec + +data SimpleValueIdentifier + = SviTopLevel ByteString -- ^ Stored in a top-level key. + | SviHash ByteString ByteString -- ^ Stored in a hash field. + +-- | Simple values, like strings, integers or enums, +-- that be represented as a single bytestring. +-- +-- Of course, any value can be represented as a single bytestring, +-- but structures like lists, hashes and sets have special support in Redis. +-- This allows insertions, updates, etc. in Redis directly, +-- but they cannot be read or written as bytestrings, and thus are not 'SimpleValue's. +class (Value inst val, Identifier val ~ SimpleValueIdentifier, Serializable val) => SimpleValue inst val + +class Serializable val where + fromBS :: ByteString -> Maybe val + toBS :: val -> ByteString + +-- | 'Ref' pointing to a 'SimpleValue'. +type SimpleRef ref = (Ref ref, SimpleValue (RefInstance ref) (ValueType ref)) + +get :: Ref ref => ref -> RedisM (RefInstance ref) (Maybe (ValueType ref)) +get = valGet . toIdentifier + +txGet :: Ref ref => ref -> Tx (RefInstance ref) (Maybe (ValueType ref)) +txGet = txValGet . toIdentifier + +set :: Ref ref => ref -> ValueType ref -> RedisM (RefInstance ref) () +set = valSet . toIdentifier + +txSet :: Ref ref => ref -> ValueType ref -> Tx (RefInstance ref) () +txSet = txValSet . toIdentifier + +delete_ :: forall ref. Ref ref => ref -> RedisM (RefInstance ref) () +delete_ = valDelete @_ @(ValueType ref) . toIdentifier + +txDelete_ :: forall ref. Ref ref => ref -> Tx (RefInstance ref) () +txDelete_ = txValDelete @_ @(ValueType ref) . toIdentifier + +-- | Atomically read and delete. +take :: Ref ref => ref -> RedisM (RefInstance ref) (Maybe (ValueType ref)) +take ref = atomically (txTake ref) + +-- | Atomically read and delete in a transaction. +txTake :: Ref ref => ref -> Tx (RefInstance ref) (Maybe (ValueType ref)) +txTake ref = txGet ref <* txDelete_ ref + +-- | Atomically set a value and return its old value. +getSet :: forall ref. SimpleRef ref => ref -> ValueType ref -> RedisM (RefInstance ref) (Maybe (ValueType ref)) +getSet ref val = case toIdentifier ref of + SviTopLevel keyBS -> + fmap (fromBS =<<) . expectRight "getSet/plain" + =<< Hedis.getset keyBS (toBS val) + + -- no native Redis call for this + SviHash _ _ -> atomically (txGet ref <* txSet ref val) + +-- | Bump the TTL without changing the content. +setTTLIfExists :: forall ref. Ref ref => ref -> TTL -> RedisM (RefInstance ref) Bool +setTTLIfExists = valSetTTLIfExists @_ @(ValueType ref) . toIdentifier + +setTTLIfExists_ :: Ref ref => ref -> TTL -> RedisM (RefInstance ref) () +setTTLIfExists_ ref = void . setTTLIfExists ref + +setTTL :: Ref ref => ref -> TTL -> RedisM (RefInstance ref) () +setTTL ref ttl = setTTLIfExists ref ttl >>= expect "setTTL: ref should exist" True + +txSetTTLIfExists :: forall ref. Ref ref => ref -> TTL -> Tx (RefInstance ref) Bool +txSetTTLIfExists = txValSetTTLIfExists @_ @(ValueType ref) . toIdentifier + +txSetTTLIfExists_ :: forall ref. Ref ref => ref -> TTL -> Tx (RefInstance ref) () +txSetTTLIfExists_ ref ttl = void $ txSetTTLIfExists ref ttl + +txSetTTL :: Ref ref => ref -> TTL -> Tx (RefInstance ref) () +txSetTTL ref ttl = + txSetTTLIfExists ref ttl + & txExpect "txSetTTL: ref should exist" True + +txSetWithTTL :: SimpleRef ref => ref -> TTL -> ValueType ref -> Tx (RefInstance ref) () +txSetWithTTL ref ttl val = txSet ref val *> txSetTTL ref ttl + +-- | Set value and TTL atomically. +setWithTTL :: forall ref. SimpleRef ref => ref -> TTL -> ValueType ref -> RedisM (RefInstance ref) () +setWithTTL ref ttl@(TTLSec ttlSec) val = case toIdentifier ref of + SviTopLevel keyBS -> Hedis.setex keyBS ttlSec (toBS val) + >>= expectRight "setWithTTL/SETEX" + >>= expect "setWithTTL/SETEX should return OK" Hedis.Ok + SviHash _ _ -> atomically (txSet ref val <* txSetTTL ref ttl) + +-- | Increment the value under the given ref. +incrementBy :: (SimpleRef ref, Num (ValueType ref)) => ref -> Integer -> RedisM (RefInstance ref) (ValueType ref) +incrementBy ref val = fmap fromInteger . expectRight "incrementBy" =<< case toIdentifier ref of + SviTopLevel keyBS -> Hedis.incrby keyBS val + SviHash keyBS hkeyBS -> Hedis.hincrby keyBS hkeyBS val + +txIncrementBy :: (SimpleRef ref, Num (ValueType ref)) => ref -> Integer -> Tx (RefInstance ref) (ValueType ref) +txIncrementBy ref val = fmap fromInteger . txWrap $ case toIdentifier ref of + SviTopLevel keyBS -> Hedis.incrby keyBS val + SviHash keyBS hkeyBS -> Hedis.hincrby keyBS hkeyBS val + +-- | Increment the value under the given ref. +incrementByFloat :: (SimpleRef ref, Floating (ValueType ref)) => ref -> Double -> RedisM (RefInstance ref) (ValueType ref) +incrementByFloat ref val = fmap realToFrac . expectRight "incrementByFloat" =<< case toIdentifier ref of + SviTopLevel keyBS -> Hedis.incrbyfloat keyBS val + SviHash keyBS hkeyBS -> Hedis.hincrbyfloat keyBS hkeyBS val + +setIfNotExists :: forall ref. SimpleRef ref => ref -> ValueType ref -> RedisM (RefInstance ref) Bool +setIfNotExists ref val = expectRight "setIfNotExists" =<< case toIdentifier ref of + SviTopLevel keyBS -> Hedis.setnx keyBS (toBS val) + SviHash keyBS hkeyBS -> Hedis.hsetnx keyBS hkeyBS (toBS val) + +setIfNotExists_ :: SimpleRef ref => ref -> ValueType ref -> RedisM (RefInstance ref) () +setIfNotExists_ ref val = void $ setIfNotExists ref val + +txSetIfNotExists :: forall ref. SimpleRef ref => ref -> ValueType ref -> Tx (RefInstance ref) Bool +txSetIfNotExists ref val = txWrap $ case toIdentifier ref of + SviTopLevel keyBS -> Hedis.setnx keyBS (toBS val) + SviHash keyBS hkeyBS -> Hedis.hsetnx keyBS hkeyBS (toBS val) + +txSetIfNotExists_ :: SimpleRef ref => ref -> ValueType ref -> Tx (RefInstance ref) () +txSetIfNotExists_ ref val = void $ txSetIfNotExists ref val + +setIfNotExistsTTL :: forall ref. SimpleRef ref => ref -> ValueType ref -> TTL -> RedisM (RefInstance ref) Bool +setIfNotExistsTTL ref val (TTLSec ttlSec) = + (== Right Hedis.Ok) <$> case toIdentifier ref of + SviHash _keyBS _hkeyBS -> error "setIfNotExistsTTL: hash keys not supported" + SviTopLevel keyBS -> Hedis.setOpts keyBS (toBS val) Hedis.SetOpts + { Hedis.setSeconds = Just ttlSec + , Hedis.setMilliseconds = Nothing + , Hedis.setCondition = Just Hedis.Nx + } + +deleteIfEqual :: forall ref. SimpleRef ref => ref -> ValueType ref -> RedisM (RefInstance ref) Bool +deleteIfEqual ref val = + fmap (/= (0 :: Integer)) . expectRight "deleteIfEqual" =<< case toIdentifier ref of + SviHash _keyBS _hkeyBS -> error "deleteIfEqual: hash keys not supported" + SviTopLevel keyBS -> Hedis.eval luaSource [keyBS] [toBS val] + where + luaSource :: ByteString + luaSource = BS.unlines + [ "if redis.call(\"get\",KEYS[1]) == ARGV[1] then" + , " return redis.call(\"del\",KEYS[1])" + , "else" + , " return 0" + , "end" + ] + +-- | Make any subsequent transaction fail if the watched ref is modified +-- between the call to 'watch' and the transaction. +watch :: SimpleRef ref => ref -> RedisM (RefInstance ref) () +watch ref = case toIdentifier ref of + SviTopLevel keyBS -> + Redis (Hedis.watch [keyBS]) >>= expect "watch/plain: OK expected" (Right Hedis.Ok) + SviHash keyBS _hkeyBS -> + Redis (Hedis.watch [keyBS]) >>= expect "watch/hash: OK expected" (Right Hedis.Ok) + +-- | Unwatch all watched keys. +-- I can't find it anywhere in the documentation +-- but I hope that this unwatches only the keys for the current connection, +-- and does not affect other connections. Nothing else would make much sense. +unwatch :: RedisM inst () +unwatch = Redis Hedis.unwatch >>= expect "unwatch: OK expected" (Right Hedis.Ok) + +-- | Decode a list of ByteStrings. +-- On failure, return the first ByteString that could not be decoded. +fromBSMany :: Serializable val => [ByteString] -> Either ByteString [val] +fromBSMany = traverse $ \valBS -> case fromBS valBS of + Just val -> Right val -- decoded correctly + Nothing -> Left valBS -- decoding failure, return the malformed bytestring + +txFromBSMany :: Serializable val => Tx inst [ByteString] -> Tx inst [val] +txFromBSMany = txCheckMap (f . fromBSMany) + where + f (Left badBS) = Left $ CouldNotDecodeValue (Just badBS) + f (Right vals) = Right vals + +instance Value inst () +instance Serializable () where + fromBS = const $ Just () + toBS = const "" +instance SimpleValue inst () + +{- conflicts with the [a] instance +instance Value inst String +instance Serializable String where + fromBS = fmap Text.unpack . fromBS + toBS = toBS . Text.pack +-} + +instance Value inst Text +instance Serializable Text where + fromBS = Just . decodeUtf8 + toBS = encodeUtf8 +instance SimpleValue inst Text + +instance Value inst Int +instance Serializable Int where + fromBS = readBS + toBS = showBS +instance SimpleValue inst Int + +instance Value inst Word32 +instance Serializable Word32 where + fromBS = readBS + toBS = showBS +instance SimpleValue inst Word32 + +instance Value inst Int64 +instance Serializable Int64 where + fromBS = readBS + toBS = showBS +instance SimpleValue inst Int64 + +instance Value inst Integer +instance Serializable Integer where + fromBS = readBS + toBS = showBS +instance SimpleValue inst Integer + +instance Value inst Double +instance Serializable Double where + fromBS = readBS + toBS = showBS +instance SimpleValue inst Double + +instance Value inst Bool +instance Serializable Bool where + fromBS "0" = Just False + fromBS "1" = Just True + fromBS _ = Nothing + + toBS True = "1" + toBS False = "0" +instance SimpleValue inst Bool + +instance Value inst UTCTime +instance Serializable UTCTime where + fromBS = readBS + toBS = showBS +instance SimpleValue inst UTCTime + +instance Value inst Day +instance Serializable Day where + fromBS = readBS + toBS = showBS +instance SimpleValue inst Day + +instance Value inst LocalTime +instance Serializable LocalTime where + fromBS = readBS + toBS = showBS +instance SimpleValue inst LocalTime + +instance Value inst ByteString +instance Serializable ByteString where + toBS = id + fromBS = Just +instance SimpleValue inst ByteString + +instance Value inst BSL.ByteString +instance Serializable BSL.ByteString where + toBS = BSL.toStrict + fromBS = Just . BSL.fromStrict +instance SimpleValue inst BSL.ByteString + +instance Serializable UUID where + toBS = toBS . UUID.toText + fromBS = UUID.fromText <=< fromBS + +instance Serializable a => Serializable (Maybe a) where + fromBS b = case BS.uncons b of + Just ('N', "") -> Just Nothing -- parsing succeeded, found Nothing + Just ('J', r) -> Just <$> fromBS r + _ -> Nothing -- Parsing failed + toBS Nothing = "N" + toBS (Just a) = "J" <> toBS a + +instance (Serializable a, Serializable b) => Serializable (Either a b) where + fromBS b = case BS.uncons b of + Just ('L', xBS) -> Left <$> fromBS xBS + Just ('R', yBS) -> Right <$> fromBS yBS + _ -> Nothing + toBS (Left x) = BS.cons 'L' (toBS x) + toBS (Right y) = BS.cons 'R' (toBS y) + +instance (SimpleValue inst a, SimpleValue inst b) => Value inst (a, b) +instance (Serializable a, Serializable b) => Serializable (a, b) where + toBS (x, y) = toBS @(Tuple '[a,b]) (x :*: y :*: Nil) + fromBS bs = + fromBS @(Tuple '[a,b]) bs <&> + \(x :*: y :*: Nil) -> (x,y) +instance (SimpleValue inst a, SimpleValue inst b) => SimpleValue inst (a,b) + +instance (SimpleValue inst a, SimpleValue inst b, SimpleValue inst c) => Value inst (a, b, c) +instance (Serializable a, Serializable b, Serializable c) => Serializable (a, b, c) where + toBS (x, y, z) = toBS (x :*: y :*: z :*: Nil) + fromBS bs = + fromBS @(Tuple '[a,b,c]) bs <&> + \(x :*: y :*: z :*: Nil) -> (x,y,z) +instance (SimpleValue inst a, SimpleValue inst b, SimpleValue inst c) => SimpleValue inst (a, b, c) + +readBS :: Read val => ByteString -> Maybe val +readBS = readMaybe . BS.unpack + +showBS :: Show val => val -> ByteString +showBS = BS.pack . show + +showBinary :: Binary val => val -> ByteString +showBinary = BSL.toStrict . encode + +readBinary :: Binary val => ByteString -> Maybe val +readBinary bytes = case decodeOrFail $ BSL.fromStrict bytes of + Left _ -> Nothing + Right (_, _, val) -> Just val + +colonSep :: [BS.ByteString] -> BS.ByteString +colonSep = BS.intercalate ":" + +infixr 3 :*: +data Tuple :: [Type] -> Type where + Nil :: Tuple '[] + (:*:) :: a -> Tuple as -> Tuple (a ': as) + +instance Eq (Tuple '[]) where + _ == _ = True + +instance Ord (Tuple '[]) where + compare _ _ = EQ + +instance (Eq a, Eq (Tuple as)) => Eq (Tuple (a ': as)) where + (x :*: xs) == (y :*: ys) = x == y && xs == ys + +instance (Ord a, Ord (Tuple as)) => Ord (Tuple (a ': as)) where + compare (x :*: xs) (y :*: ys) = compare x y <> compare xs ys + +class Serializables (as :: [Type]) where + encodeSerializables :: Tuple as -> [BS.ByteString] + decodeSerializables :: [BS.ByteString] -> Maybe (Tuple as) + +instance Serializables '[] where + encodeSerializables Nil = [] + + decodeSerializables [] = Just Nil + decodeSerializables _ = Nothing + +instance (Serializable a, Serializables as) => Serializables (a ': as) where + encodeSerializables (x :*: xs) = toBS x : encodeSerializables xs + + decodeSerializables [] = Nothing + decodeSerializables (bs : bss) = (:*:) <$> fromBS bs <*> decodeSerializables bss + +instance Serializables as => Value inst (Tuple as) +instance Serializables as => Serializable (Tuple as) where + toBS = encodeBSs . encodeSerializables + where + -- Encode a list of bytestrings into a single bytestring + -- that's unambiguous (for machines) but human-readable (for humans). + -- + -- This is useful for tuples and records + -- that you need to put in a Redis list or a Redis set + -- so they need to be Serializables. + -- + -- The format: + -- ,,...,:::...: + -- + -- Lengths are base10 numbers, strings are literal binary strings. + encodeBSs :: [BS.ByteString] -> BS.ByteString + encodeBSs bss = BS.intercalate ":" (lengths : bss) + where + lengths = BS.intercalate "," [BS.pack (show (BS.length bs)) | bs <- bss] + + fromBS = decodeSerializables <=< decodeBSs + where + decodeBSs :: BS.ByteString -> Maybe [BS.ByteString] + decodeBSs bsWhole = do + lengths <- traverse fromBS $ BS.split ',' bsLengths + splitLengths lengths bsData + where + -- bsData starts with a colon + (bsLengths, bsData) = BS.span (/= ':') bsWhole + + splitLengths [] "" = Just [] + splitLengths [] _trailingGarbage = Nothing + splitLengths (l:ls) bs = case BS.uncons bs of + Just (':', bsNoColon) -> + let (item, rest) = BS.splitAt l bsNoColon + in (item :) <$> splitLengths ls rest + + _ -> Nothing +instance Serializables as => SimpleValue inst (Tuple as) + +day :: TTL +day = 24 * hour + +hour :: TTL +hour = 60 * minute + +minute :: TTL +minute = 60 * second + +second :: TTL +second = TTLSec 1 + +-- | Redis lists. +instance Serializable a => Value inst [a] where + type Identifier [a] = ByteString + + txValGet keyBS = + txWrap (Hedis.lrange keyBS 0 (-1)) + & txFromBSMany + & fmap Just + txValSet keyBS vs = void $ txWrap (Hedis.del [keyBS] *> Hedis.rpush keyBS (map toBS vs)) + txValDelete keyBS = void $ txWrap (Hedis.del [keyBS]) + txValSetTTLIfExists keyBS (TTLSec ttlSec) = txWrap (Hedis.expire keyBS ttlSec) + + valGet keyBS = + Redis (Hedis.lrange keyBS 0 (-1)) + >>= expectRight "valGet/[a]" + >>= (fromBSMany <&> \case + Left badBS -> throw $ CouldNotDecodeValue (Just badBS) + Right vs -> pure (Just vs)) + + valSet keyBS vs = + Redis (Hedis.multiExec (Hedis.del [keyBS] *> Hedis.rpush keyBS (map toBS vs))) + >>= expectTxSuccess + >>= ignore @Integer + valDelete keyBS = + Redis (Hedis.del [keyBS]) + >>= expectRight "valDelete/[a]" + >>= ignore @Integer + valSetTTLIfExists keyBS (TTLSec ttlSec) = + Redis (Hedis.expire keyBS ttlSec) + >>= expectRight "valSetTTLIfExists/[a]" + +-- | Append to a Redis list. +lAppend :: forall ref a. (Ref ref, ValueType ref ~ [a], Serializable a) => ref -> [a] -> RedisM (RefInstance ref) () +lAppend (toIdentifier -> keyBS) vals = + Redis (Hedis.rpush keyBS (map toBS vals)) + >>= expectRight "rpush" + >>= ignore @Integer + +-- | Append to a Redis list in a transaction. +txLAppend :: forall ref a. (Ref ref, ValueType ref ~ [a], Serializable a) => ref -> [a] -> Tx (RefInstance ref) () +txLAppend (toIdentifier -> keyBS) vals = + void . txWrap $ Hedis.rpush keyBS (map toBS vals) + +-- | Length of a Redis list +lLength :: forall ref a. (Ref ref, ValueType ref ~ [a], Serializable a) => ref -> RedisM (RefInstance ref) Integer +lLength (toIdentifier -> keyBS) = + Redis (Hedis.llen keyBS) + >>= expectRight "llen" + +-- | Prepend to a Redis list. +lPushLeft :: forall ref a. (Ref ref, ValueType ref ~ [a], Serializable a) => ref -> [a] -> RedisM (RefInstance ref) () +lPushLeft (toIdentifier -> keyBS) vals = + Redis (Hedis.lpush keyBS (map toBS vals)) + >>= expectRight "lpush" + >>= ignore @Integer + +-- | Pop from the right. +lPopRight :: forall ref a. (Ref ref, ValueType ref ~ [a], Serializable a) => ref -> RedisM (RefInstance ref) (Maybe a) +lPopRight (toIdentifier -> keyBS) = + Redis (Hedis.rpop keyBS) + >>= fmap (fromBS =<<) . expectRight "rpop" + +-- | Pop from the right, blocking. +lPopRightBlocking :: forall ref a. (Ref ref, ValueType ref ~ [a], Serializable a) => TTL -> ref -> RedisM (RefInstance ref) (Maybe a) +lPopRightBlocking (TTLSec timeoutSec) (toIdentifier -> keyBS) = + Redis (Hedis.brpop [keyBS] timeoutSec) + >>= expectRight "brpop" + >>= \case + Nothing -> pure Nothing -- timeout + Just (_listName, valBS) -> + case fromBS valBS of + Just val -> pure $ Just val + Nothing -> throw $ CouldNotDecodeValue (Just valBS) + +-- | Delete from a Redis list +lRem :: forall ref a. (Ref ref, ValueType ref ~ [a], Serializable a) => ref -> Integer -> a -> RedisM (RefInstance ref) () +lRem (toIdentifier -> keyBS) num val = + Redis (Hedis.lrem keyBS num (toBS val)) + >>= expectRight "lrem" + >>= ignore @Integer + + +-- | Redis sets. +instance (Serializable a, Ord a) => Value inst (Set a) where + type Identifier (Set a) = ByteString + + txValGet keyBS = + txWrap (Hedis.smembers keyBS) + & txFromBSMany + & fmap (Just . Set.fromList) + + txValSet keyBS vs = + void $ txWrap ( + Hedis.del [keyBS] + *> Hedis.sadd keyBS (map toBS $ Set.toList vs) + ) + + txValDelete keyBS = void $ txWrap (Hedis.del [keyBS]) + txValSetTTLIfExists keyBS (TTLSec ttlSec) = txWrap (Hedis.expire keyBS ttlSec) + + valGet keyBS = + Hedis.smembers keyBS + >>= expectRight "valGet/Set a" + >>= (fromBSMany <&> \case + Left badBS -> throw $ CouldNotDecodeValue (Just badBS) + Right vs -> pure (Just $ Set.fromList vs)) + + valSet keyBS vs = + Redis (Hedis.multiExec ( + Hedis.del [keyBS] + *> Hedis.sadd keyBS (map toBS $ Set.toList vs) + )) + >>= expectTxSuccess + >>= ignore @Integer + + valDelete keyBS = Redis (Hedis.del [keyBS]) + >>= expectRight "valDelete/Set a" + >>= ignore @Integer + + valSetTTLIfExists keyBS (TTLSec ttlSec) = + Redis (Hedis.expire keyBS ttlSec) + >>= expectRight "valSetTTLIfExists/Set a" + +-- | Insert into a Redis set. +sInsert :: forall ref a. (Ref ref, ValueType ref ~ Set a, Serializable a) => ref -> [a] -> RedisM (RefInstance ref) () +sInsert ref vals = + Redis (Hedis.sadd (toIdentifier ref) (map toBS vals)) + >>= expectRight "setInsert" + >>= ignore @Integer + +-- | Insert into a Redis set in a transaction. +txSInsert :: forall ref a. (Ref ref, ValueType ref ~ Set a, Serializable a) => ref -> [a] -> Tx (RefInstance ref) () +txSInsert ref vals = + void . txWrap + $ Hedis.sadd (toIdentifier ref) (map toBS vals) + +-- | Delete from a Redis set. +sDelete :: forall ref a. (Ref ref, ValueType ref ~ Set a, Serializable a) => ref -> [a] -> RedisM (RefInstance ref) () +sDelete ref vals = + Redis (Hedis.srem (toIdentifier ref) (map toBS vals)) + >>= expectRight "hashSetDelete" + >>= ignore @Integer + +-- | Delete from a Redis set in a transaction. +txSDelete :: forall ref a. (Ref ref, ValueType ref ~ Set a, Serializable a) => ref -> [a] -> Tx (RefInstance ref) () +txSDelete ref vals = + void . txWrap + $ Hedis.srem (toIdentifier ref) (map toBS vals) + +-- | Check membership in a Redis set. +sContains :: forall ref a. (Ref ref, ValueType ref ~ Set a, Serializable a) => ref -> a -> RedisM (RefInstance ref) Bool +sContains ref val = + Redis (Hedis.sismember (toIdentifier ref) (toBS val)) + >>= expectRight "setContains" + +-- | Check membership in a Redis set, in a transaction. +txSContains :: forall ref a. (Ref ref, ValueType ref ~ Set a, Serializable a) => ref -> a -> Tx (RefInstance ref) Bool +txSContains ref val = + txWrap $ Hedis.sismember (toIdentifier ref) (toBS val) + +-- | Get set size. +sSize :: (Ref ref, ValueType ref ~ Set a) => ref -> RedisM (RefInstance ref) Integer +sSize ref = Redis (Hedis.scard (toIdentifier ref)) >>= expectRight "setSize" + +-- | Get set size, in a transaction. +txSSize :: (Ref ref, ValueType ref ~ Set a) => ref -> Tx (RefInstance ref) Integer +txSSize ref = txWrap $ Hedis.scard (toIdentifier ref) + +-- | Priority for a sorted set +newtype Priority = Priority { unPriority :: Double } + +instance Serializable Priority where + fromBS = fmap Priority . fromBS + toBS = toBS . unPriority + +instance Bounded Priority where + minBound = Priority (-Numeric.Limits.maxValue) + maxBound = Priority Numeric.Limits.maxValue + +-- | Add elements to a sorted set +zInsert :: forall ref a. (Ref ref, ValueType ref ~ [(Priority, a)], Serializable a) => ref -> [(Priority, a)] -> RedisM (RefInstance ref) () +zInsert (toIdentifier -> keyBS) vals = + Redis (Hedis.zadd keyBS (map (unPriority Arrow.*** toBS) vals)) + >>= expectRight "zadd" + >>= ignore @Integer + +-- | Delete from a Redis sorted set +zDelete :: forall ref a. (Ref ref, ValueType ref ~ [(Priority, a)], Serializable a) => ref -> a -> RedisM (RefInstance ref) () +zDelete (toIdentifier -> keyBS) val = + Redis (Hedis.zrem keyBS [toBS val]) + >>= expectRight "zrem" + >>= ignore @Integer + +-- | Get the cardinality (number of elements) of a sorted set +zSize :: forall ref a. (Ref ref, ValueType ref ~ [(Priority, a)], Serializable a) => ref -> RedisM (RefInstance ref) Integer +zSize (toIdentifier -> keyBS) = + Redis (Hedis.zcard keyBS) + >>= expectRight "zcard" + +-- | Returns the number of elements in the sorted set that have a score between minScore and +-- maxScore inclusive. +zCount :: forall ref a. (Ref ref, ValueType ref ~ [(Priority, a)], Serializable a) => ref -> Priority -> Priority -> RedisM (RefInstance ref) Integer +zCount (toIdentifier -> keyBS) (unPriority -> minScore) (unPriority -> maxScore) = + Redis (Hedis.zcount keyBS minScore maxScore) + >>= expectRight "zcount" + +-- | Remove given number of smallest elements from a sorted set. +-- Available since Redis 5.0.0 +zPopMin :: forall ref a. (Ref ref, ValueType ref ~ [(Priority, a)], Serializable a) => ref -> Integer -> RedisM (RefInstance ref) [(Priority, a)] +zPopMin (toIdentifier -> keyBS) cnt = + Redis (zpopmin keyBS cnt) + >>= expectRight "zpopmin call" + >>= expectRight "zpopmin decode" . fromBSMany' + where fromBSMany' = traverse $ \(valBS,sc) -> maybe (Left valBS) (Right . (Priority sc,)) $ fromBS valBS + +-- | ZPOPMIN as it should be in the Hedis library (but it isn't yet) +-- Available since Redis 5.0.0 +zpopmin :: Hedis.RedisCtx m f => ByteString -> Integer -> m (f [(ByteString, Double)]) +zpopmin k c = Hedis.sendRequest ["ZPOPMIN", k, toBS c] + +-- | Remove the smallest element from a sorted set, and block for the given number of seconds when it is not there yet. +-- Available since Redis 5.0.0 +bzPopMin :: forall ref a. (Ref ref, ValueType ref ~ [(Priority, a)], Serializable a) + => ref -> Integer -> RedisM (RefInstance ref) (Maybe (Priority, a)) +bzPopMin (toIdentifier -> keyBS) timeout = + Redis (bzpopmin keyBS timeout) + >>= expectRight "bzPopMin call" + >>= expectRight "bzPopMin decode" . fromBS' + where + fromBS' = maybe (Right Nothing) (\(_,valBS,sc) -> maybe (Left valBS) (Right . Just . (Priority sc,)) $ fromBS valBS) + +-- | BZPOPMIN as it should be in the Hedis library (but it isn't yet) +-- Available since Redis 5.0.0 +bzpopmin :: Hedis.RedisCtx m f => ByteString -> Integer -> m (f (Maybe (ByteString, ByteString, Double))) +bzpopmin k timeout = Hedis.sendRequest ["BZPOPMIN", k, toBS timeout] + +-- Orphan instance, Hedis only implements this for 2-tuples, but BZPOPMIN gets 3 results +instance (Hedis.RedisResult a, Hedis.RedisResult b, Hedis.RedisResult c) => Hedis.RedisResult (a,b,c) where + decode (Hedis.MultiBulk (Just [x,y,z])) = (,,) <$> Hedis.decode x <*> Hedis.decode y <*> Hedis.decode z + decode r = Left r + +-- | Get elements from a sorted set, between the given min and max values, and with the given offset and limit. +zRangeByScoreLimit :: forall ref a. (Ref ref, ValueType ref ~ [(Priority, a)], Serializable a) + => ref -> Priority -> Priority -> Integer -> Integer -> RedisM (RefInstance ref) [a] +zRangeByScoreLimit (toIdentifier -> keyBS) (Priority minV) (Priority maxV) offset limit = + Hedis.zrangebyscoreLimit keyBS minV maxV offset limit + >>= expectRight "zrangebyscoreLimit call" + >>= expectRight "zrangebyscoreLimit decode" . fromBSMany + +parseMap :: (Ord k, Serializable k, Serializable v) + => [(ByteString, ByteString)] -> Maybe (Map k v) +parseMap kvsBS = Map.fromList <$> sequence + [ (,) <$> fromBS keyBS <*> fromBS valBS + | (keyBS, valBS) <- kvsBS + ] + +-- | Redis hashes. +instance (Ord k, Serializable k, Serializable v) => Value inst (Map k v) where + type Identifier (Map k v) = ByteString + + txValGet keyBS = + txWrap (Hedis.hgetall keyBS) + & txCheckMap ( + maybe + (Left $ CouldNotDecodeValue Nothing) + (Right . Just) + . parseMap + ) + + txValSet keyBS m = + void $ txWrap ( + Hedis.del [keyBS] + *> Hedis.hmset keyBS + [(toBS ref, toBS val) | (ref, val) <- Map.toList m] + ) + + txValDelete keyBS = void . txWrap $ Hedis.del [keyBS] + txValSetTTLIfExists keyBS (TTLSec ttlSec) = + txWrap $ Hedis.expire keyBS ttlSec + + valGet keyBS = + Hedis.hgetall keyBS + >>= expectRight "valGet/Map k v" + >>= \kvsBS -> case parseMap kvsBS of + Just m -> pure (Just m) + Nothing -> throw $ CouldNotDecodeValue Nothing + + valSet keyBS m = + Redis (Hedis.multiExec ( + Hedis.del [keyBS] + *> Hedis.hmset keyBS + [(toBS ref, toBS val) | (ref, val) <- Map.toList m] + )) + >>= expectTxSuccess + >>= expect "valSet/Map k v" Hedis.Ok + + valDelete keyBS = + Redis (Hedis.del [keyBS]) + >>= expectRight "valDelete/Map k v" + >>= ignore @Integer + + valSetTTLIfExists keyBS (TTLSec ttlSec) = + Redis (Hedis.expire keyBS ttlSec) + >>= expectRight "setTTLIfExists/Map k v" + +infix 3 :/ +-- | Map field addressing operator. +-- If @ref@ is a 'Ref' pointing to a @Map k v@, +-- then @(ref :/ k)@ is a ref with type @v@, +-- pointing to the entry in the map identified by @k@. +data MapItem :: Type -> Type -> Type -> Type where + (:/) :: (Ref ref, ValueType ref ~ Map k v) => ref -> k -> MapItem ref k v + + -- Previously, 'MapItem' was defined simply as + -- > data MapItem ref k v = (:/) ref k + -- However, this caused GHC to choke on this because it provided no way + -- to infer the value of 'v' from @ref :/ k@ alone -- 'v' is a phantom type, + -- not mentioned in the expression. + -- + -- This would block the instance resolution for @Ref (MapItem ref k v)@ + -- for any expression of the form @ref :/ k@, and cause more trouble down the line. + -- + -- Hence I made 'MapItem' a GADT so that the type inference machine + -- has clear instructions how to infer the correct value of 'v'. + +instance + ( Ref ref + , ValueType ref ~ Map k v + , Serializable k + , SimpleValue (RefInstance ref) v + ) => Ref (MapItem ref k v) where + + type ValueType (MapItem ref k v) = v + type RefInstance (MapItem ref k v) = RefInstance ref + toIdentifier (mapRef :/ k) = SviHash (toIdentifier mapRef) (toBS k) + +infix 3 :. +-- | Record item addressing operator. +-- If @ref@ is a ref pointing to a @Record fieldF@, +-- and @k :: fieldF v@ is a field of that record, +-- then @(ref :. k)@ is a ref with type @v@, +-- pointing to that field of that record. +data RecordItem ref fieldF val = (:.) ref (fieldF val) + +-- | Class of record fields. See 'Record' for details. +class RecordField (fieldF :: Type -> Type) where + rfToBS :: fieldF a -> ByteString + +instance + ( Ref ref + , ValueType ref ~ Record fieldF + , SimpleValue (RefInstance ref) val + , RecordField fieldF + ) => Ref (RecordItem ref fieldF val) where + + type ValueType (RecordItem ref fieldF val) = val + type RefInstance (RecordItem ref fieldF val) = RefInstance ref + toIdentifier (ref :. field) = SviHash (toIdentifier ref) (rfToBS field) + +-- | The value type for refs that point to records. +-- Can be deleted and SetTTLed. +-- Can't be read or written as a whole (at the moment). +-- +-- The parameter @fieldF@ gives the field functor for this record. +-- This is usually a GADT indexed by the type of the corresponding record field. +-- +-- 'Record' and 'Map' are related but different: +-- +-- * 'Map' is a homogeneous variable-size collection of associations @k -> v@, +-- where all refs have the same type and all values have the same type, +-- just like a Haskell 'Map'. +-- +-- 'Map's can be read/written to Redis as whole entities out-of-the-box. +-- +-- * 'Record' is a heterogeneous fixed-size record of items with different types, +-- just like Haskell records. +-- +-- 'Record's cannot be read/written whole at the moment. +-- There's no special reason for that, except that it would probably be +-- too much type-level code that noone needs at the moment. +-- +-- See also: '(:.)'. +data Record (fieldF :: Type -> Type) + +-- This is a bit of a hack. Records can't be written at the moment. +-- Maybe we should split the Value typeclass into ReadWriteValue and Value +instance Value inst (Record fieldF) where + type Identifier (Record fieldF) = ByteString + txValGet _ = error "Record is not meant to be read" + txValSet _ _ = error "Record is not meant to be written" + txValDelete keyBS = void . txWrap $ Hedis.del [keyBS] + txValSetTTLIfExists keyBS (TTLSec ttlSec) = txWrap $ Hedis.expire keyBS ttlSec + valGet _ = error "Record is not meant to be read" + valSet _ _ = error "Record is not meant to be written" + valDelete keyBS = Hedis.del [keyBS] + >>= expectRight "valDelete/Record" >>= ignore @Integer + valSetTTLIfExists keyBS (TTLSec ttlSec) = + Hedis.expire keyBS ttlSec >>= expectRight "setTTLIfExists/Record" + +unliftIO :: ((forall a. RedisM inst a -> IO a) -> IO b) -> RedisM inst b +unliftIO action = Redis $ Hedis.reRedis $ do + env <- ask + liftIO $ action $ + \(Redis redisA) -> runReaderT (Hedis.unRedis redisA) env + +-- | PubSub channels. +data PubSub msg + +instance Value inst (PubSub msg) where + type Identifier (PubSub msg) = ByteString + txValGet _ = error "PubSub is not meant to be read" + txValSet _ _ = error "PubSub is not meant to be written" + txValDelete keyBS = void . txWrap $ Hedis.del [keyBS] + txValSetTTLIfExists keyBS (TTLSec ttlSec) = txWrap $ Hedis.expire keyBS ttlSec + valGet _ = error "PubSub is not meant to be read" + valSet _ _ = error "PubSub is not meant to be written" + valDelete keyBS = Hedis.del [keyBS] + >>= expectRight "valDelete/PubSub" >>= ignore @Integer + valSetTTLIfExists keyBS (TTLSec ttlSec) = + Hedis.expire keyBS ttlSec >>= expectRight "setTTLIfExists/PubSub" + +pubSubListen :: (Ref ref, ValueType ref ~ PubSub msg, Serializable msg) + => ref -> (Either RedisException msg -> IO Bool) -> RedisM (RefInstance ref) () +pubSubListen (toIdentifier -> keyBS) process = + Redis $ Hedis.pubSub (Hedis.subscribe [keyBS]) $ \rawMsg -> + let msg = case fromBS (Hedis.msgMessage rawMsg) of + Nothing -> Left (CouldNotDecodeValue $ Just (Hedis.msgMessage rawMsg)) + Just msg' -> Right msg' + in liftIO (process msg) >>= \case + True -> return mempty + False -> return (Hedis.unsubscribe [keyBS]) + +pubSubCountSubs :: (Ref ref, ValueType ref ~ PubSub msg) + => ref -> RedisM (RefInstance ref) Integer +pubSubCountSubs (toIdentifier -> keyBS) = + Hedis.sendRequest ["PUBSUB", "NUMSUB", keyBS] + >>= expectRight "pubSubCountSubs" + >>= \case + Hedis.MultiBulk (Just [_, Hedis.Integer cnt]) -> return cnt + _ -> error "pubSubCountSubs: unexpected reply" diff --git a/src/Database/Redis/Schema/Lock.hs b/src/Database/Redis/Schema/Lock.hs new file mode 100644 --- /dev/null +++ b/src/Database/Redis/Schema/Lock.hs @@ -0,0 +1,354 @@ +{-# LANGUAGE Strict #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Database.Redis.Schema.Lock + ( LockParams(..), ShareableLockParams(..) + , defaultMetaParams + , ExclusiveLock, withExclusiveLock + , ShareableLock, withShareableLock, LockSharing(..) + ) + where + +import GHC.Generics +import Data.Functor ( void ) +import Data.Kind ( Type ) +import Data.Maybe ( fromMaybe ) +import Data.Time ( NominalDiffTime, addUTCTime, getCurrentTime ) +import Data.Set ( Set ) +import Data.ByteString ( ByteString ) +import qualified Data.Set as Set +import qualified Data.ByteString.Char8 as BS + +import System.Random ( randomIO ) + +import Control.Concurrent ( threadDelay, myThreadId ) +import Control.Monad.Fix ( fix ) +import Control.Monad.Catch ( MonadThrow(..), MonadCatch(..), MonadMask(..), throwM, finally ) +import Control.Monad.IO.Class ( liftIO, MonadIO ) + +import qualified Database.Redis.Schema as Redis + +data LockParams = LockParams + { lpMeanRetryInterval :: NominalDiffTime + , lpAcquireTimeout :: NominalDiffTime + , lpLockTTL :: Redis.TTL + } + +-- | ID of the process that owns the Redis lock. +newtype LockOwnerId = LockOwnerId { _unLockOwnerId :: ByteString } + deriving newtype (Eq, Ord, Redis.Serializable) +instance Redis.Value inst LockOwnerId +instance Redis.SimpleValue inst LockOwnerId + +-------------------- +-- Exclusive lock -- +-------------------- + +-- | Redis value representing the exclusive lock. +newtype ExclusiveLock = ExclusiveLock + { _elOwnerId :: LockOwnerId + } + deriving newtype (Eq, Redis.Serializable) +instance Redis.Value inst ExclusiveLock +instance Redis.SimpleValue inst ExclusiveLock + +-- | Execute the given action in an exclusively locked context. +-- +-- This is useful mainly for operations that need to be atomic +-- while manipulating *both* Redis and database (such as various commit scripts). +-- +-- * For Redis-only transactions, use 'Redis.atomically'. +-- +-- * For database-only transactions, use database transactions. +-- +-- * For shareable locks, use 'withShareableLock'. +-- +-- * For exclusive locks, 'withExclusiveLock' is more efficient. +-- +withExclusiveLock :: + ( MonadCatch m, MonadThrow m, MonadMask m, MonadIO m + , Redis.Ref ref, Redis.ValueType ref ~ ExclusiveLock + ) + => Redis.Pool (Redis.RefInstance ref) + -> LockParams -- ^ Params of the lock, such as timeouts or TTL. + -> ref -- ^ Lock ref + -> m a -- ^ The action to perform under lock + -> m a +withExclusiveLock redis lp ref action = do + exclusiveLockAcquire redis lp ref >>= \case + Nothing -> throwM Redis.LockAcquireTimeout + Just ourId -> action `finally` exclusiveLockRelease redis ref ourId + +-- | Acquire a distributed exclusive lock. +-- Returns Nothing on timeout. Otherwise it returns the unique client ID used for the lock. +exclusiveLockAcquire :: + ( MonadCatch m, MonadThrow m, MonadMask m, MonadIO m + , Redis.Ref ref, Redis.ValueType ref ~ ExclusiveLock + ) + => Redis.Pool (Redis.RefInstance ref) -> LockParams -> ref -> m (Maybe LockOwnerId) +exclusiveLockAcquire redis lp ref = do + -- this is unique only if we have only one instance of HConductor running + ourId <- LockOwnerId . BS.pack . show <$> liftIO myThreadId -- unique client id + tsDeadline <- addUTCTime (lpAcquireTimeout lp) <$> liftIO getCurrentTime + fix $ \ ~retry -> do -- ~ makes the lambda lazy + tsNow <- liftIO getCurrentTime + if tsNow >= tsDeadline + then return Nothing -- didn't manage to acquire the lock before timeout + else do + -- set the lock if it does not exist + didNotExist <- Redis.run redis $ + Redis.setIfNotExistsTTL ref (ExclusiveLock ourId) (lpLockTTL lp) + if didNotExist + then return (Just ourId) -- everything went well + else do + -- someone got there first; wait a bit and try again + fuzzySleep (lpMeanRetryInterval lp) + retry + +exclusiveLockRelease :: + ( MonadCatch m, MonadThrow m, MonadMask m, MonadIO m + , Redis.Ref ref, Redis.ValueType ref ~ ExclusiveLock + ) + => Redis.Pool (Redis.RefInstance ref) -> ref -> LockOwnerId -> m () +exclusiveLockRelease redis ref ourId = + -- While we were locked, the lock could have expired + -- and someone else could have acquired the lock in the meantime. + -- + -- To avoid deleting someone else's lock, we need to check if it's ours. + void + $ Redis.run redis + $ Redis.deleteIfEqual ref (ExclusiveLock ourId) + + +-------------------- +-- Shareable lock -- +-------------------- + +data LockSharing + = Shared + | Exclusive + deriving (Eq, Ord, Show, Read, Generic) +instance Redis.Value inst LockSharing +instance Redis.Serializable LockSharing where + toBS Shared = "shared" + toBS Exclusive = "exclusive" + fromBS "shared" = Just Shared + fromBS "exclusive" = Just Exclusive + fromBS _ = Nothing +instance Redis.SimpleValue inst LockSharing + +data LockFieldName :: Type -> Type where + LockFieldSharing :: LockFieldName LockSharing + LockFieldOwners :: LockFieldName (Set LockOwnerId) + +-- Ref that points to the components of a shareable lock. +data LockField :: Type -> Type -> Type where + LockField :: ByteString -> LockFieldName ty -> LockField inst ty + +instance Redis.Value inst ty => Redis.Ref (LockField inst ty) where + type ValueType (LockField inst ty) = ty + type RefInstance (LockField inst ty) = inst + toIdentifier (LockField lockSlugBS LockFieldSharing) = Redis.SviTopLevel + $ Redis.colonSep [ "lock", lockSlugBS, "sharing"] + toIdentifier (LockField lockSlugBS LockFieldOwners) = + Redis.colonSep [ "lock", lockSlugBS, "owners"] + +-- Ref that points to the meta lock of the shareable lock. +-- A meta lock is always an exclusive lock +-- and it synchronises the access to the components of the shareable lock. +newtype MetaLock ref = MetaLock ref + +instance (Redis.Ref ref, Redis.ValueType ref ~ ShareableLock) + => Redis.Ref (MetaLock ref) where + + type ValueType (MetaLock ref) = ExclusiveLock + type RefInstance (MetaLock ref) = Redis.RefInstance ref + + toIdentifier (MetaLock ref) = Redis.SviTopLevel $ Redis.colonSep + [ "lock" + , Redis.toIdentifier ref + , "meta" + ] + +data ShareableLock = ShareableLock + { lockSharing :: LockSharing + , lockOwners :: Set LockOwnerId + } + +instance Redis.Value inst ShareableLock where + type Identifier ShareableLock = ByteString + + txValGet slugBS = do + mbSharing <- Redis.txGet (LockField slugBS LockFieldSharing) + mbOwners <- Redis.txGet (LockField slugBS LockFieldOwners) + pure $ case mbSharing of + Nothing -> Nothing -- lock does not exist + Just lockSharing -> Just + $ ShareableLock lockSharing (fromMaybe Set.empty mbOwners) + + txValSet slugBS lock = + Redis.txSet (LockField slugBS LockFieldSharing) (lockSharing lock) + *> Redis.txSet (LockField slugBS LockFieldOwners) (lockOwners lock) + + txValDelete slugBS = + Redis.txDelete_ (LockField slugBS LockFieldSharing) + *> Redis.txDelete_ (LockField slugBS LockFieldOwners) + + txValSetTTLIfExists slugBS ttl = (||) + <$> Redis.txSetTTLIfExists (LockField slugBS LockFieldSharing) ttl + <*> Redis.txSetTTLIfExists (LockField slugBS LockFieldOwners) ttl + + valGet slugBS = Redis.atomically $ Redis.txValGet slugBS + valSet slugBS val = Redis.atomically $ Redis.txValSet slugBS val + valDelete slugBS = Redis.atomically $ Redis.txValDelete @inst @ShareableLock slugBS + valSetTTLIfExists slugBS ttl = Redis.atomically + $ Redis.txValSetTTLIfExists @inst @ShareableLock slugBS ttl + +data ShareableLockParams = ShareableLockParams + { slpParams :: LockParams + , slpMetaParams :: LockParams + } + +defaultMetaParams :: LockParams +defaultMetaParams = LockParams + { lpMeanRetryInterval = 50e-3 + , lpAcquireTimeout = 500e-3 + , lpLockTTL = 2 * Redis.second + } + +-- | Execute the given action in a locked, possibly shared context. +-- +-- This is useful mainly for operations that need to be atomic +-- while manipulating *both* Redis and database (such as various commit scripts). +-- +-- * For Redis-only transactions, use 'atomically'. +-- +-- * For database-only transactions, use database transactions. +-- +-- * For exclusive locks, withExclusiveLock is more efficient. +-- +-- NOTE: the shareable lock seems to have quite a lot of performance overhead. +-- Always benchmark first whether the exclusive lock would perform better in your scenario, +-- even when a shareable lock would be sufficient in theory. +withShareableLock + :: ( MonadCatch m, MonadThrow m, MonadMask m, MonadIO m + , Redis.Ref ref, Redis.ValueType ref ~ ShareableLock + , Redis.SimpleValue (Redis.RefInstance ref) (MetaLock ref) + ) + => Redis.Pool (Redis.RefInstance ref) + -> ShareableLockParams -- ^ Params of the lock, such as timeouts or TTL. + -> LockSharing -- ^ Shared / Exclusive + -> ref -- ^ Lock ref + -> m a -- ^ The action to perform under lock + -> m a +withShareableLock redis slp lockSharing ref action = + shareableLockAcquire redis slp lockSharing ref >>= \case + Nothing -> throwM Redis.LockAcquireTimeout + Just ourId -> action + `finally` shareableLockRelease redis slp ref lockSharing ourId + +shareableLockAcquire :: + forall m ref. + ( MonadCatch m, MonadThrow m, MonadMask m, MonadIO m + , Redis.Ref ref, Redis.ValueType ref ~ ShareableLock + , Redis.SimpleValue (Redis.RefInstance ref) (MetaLock ref) + ) => Redis.Pool (Redis.RefInstance ref) -> ShareableLockParams -> LockSharing -> ref -> m (Maybe LockOwnerId) +shareableLockAcquire redis slp lockSharing ref = do + -- this is unique only if we have only one instance of HConductor running + ourId <- LockOwnerId . BS.pack . show <$> liftIO myThreadId -- unique client id + tsDeadline <- addUTCTime (lpAcquireTimeout $ slpParams slp) <$> liftIO getCurrentTime + fix $ \ ~retry -> do -- ~ makes the lambda lazy + tsNow <- liftIO getCurrentTime + if tsNow >= tsDeadline + then return Nothing -- didn't manage to acquire the lock before timeout + else do + -- acquire the lock if possible, using the meta lock to synchronise access + success <- withExclusiveLock redis (slpMetaParams slp) (MetaLock ref) $ + Redis.run redis $ do + -- get just the sharing flag + -- avoid getting the list of all owners + Redis.get (lockField LockFieldSharing) >>= \case + -- no lock, just acquire it + Nothing -> do + Redis.set ref $ ShareableLock lockSharing (Set.singleton ourId) + return True + + -- lock is shareably acquired + -- we want to share + -- so we can acquire + Just Shared | lockSharing == Shared -> do + Redis.sInsert (lockField LockFieldOwners) [ourId] + return True + + -- can't acquire lock otherwise + _ -> return False + + if success + then do + -- everything went well, set ttl and return + Redis.run redis $ Redis.setTTL ref (lpLockTTL $ slpParams slp) + return (Just ourId) + else do + -- someone got there first; wait a bit and try again + fuzzySleep $ lpMeanRetryInterval (slpParams slp) + retry + where + lockField :: LockFieldName ty -> LockField (Redis.RefInstance ref) ty + lockField = LockField (Redis.toIdentifier ref) + +shareableLockRelease :: + forall m ref. + ( MonadCatch m, MonadThrow m, MonadMask m, MonadIO m + , Redis.Ref ref, Redis.ValueType ref ~ ShareableLock + , Redis.SimpleValue (Redis.RefInstance ref) (MetaLock ref) + ) => Redis.Pool (Redis.RefInstance ref) -> ShareableLockParams -> ref -> LockSharing -> LockOwnerId -> m () +shareableLockRelease redis slp ref lockSharing ourId = + withExclusiveLock redis (slpMetaParams slp) (MetaLock ref) $ Redis.run redis $ do + -- While we were locked, the lock could have expired + -- and someone else could have acquired the lock in the meantime. + -- + -- To avoid deleting someone else's lock, we need to check if it's ours. + Redis.sContains (lockField LockFieldOwners) ourId >>= \case + False -> pure () -- lock is not ours, nothing to do here + True -> case lockSharing of + -- we can delete the lock without further exchange with Redis + Exclusive -> Redis.delete_ ref + + -- we need to check if we're the last owner + Shared -> do + -- (the set item could expire here so size could be zero) + size <- Redis.sSize (lockField LockFieldOwners) + if size <= 1 + -- delete the whole lock + then Redis.delete_ ref + -- just remove ourselves from the list of owners + else Redis.sDelete (lockField LockFieldOwners) [ourId] + where + lockField :: LockFieldName ty -> LockField (Redis.RefInstance ref) ty + lockField = LockField (Redis.toIdentifier ref) + +-- | Sleep between 0.75 and 1.25 times the given time, uniformly randomly. +fuzzySleep :: MonadIO m => NominalDiffTime -> m () +fuzzySleep interval = liftIO $ do + -- randomise wait time slightly + r <- randomIO :: IO Double -- r is between 0.0 and 1.0 + let q = 1 + (r - 0.5) / 2 -- q is between 0.75 and 1.25 + -- NominalDiffTime behaves like seconds; threadDelay takes microseconds + threadDelay (round $ 1e6 * realToFrac q * interval)