redis-schema (empty) → 0.1.0

raw patch · 7 files changed

+2609/−0 lines, 7 filesdep +basedep +binarydep +bytestringsetup-changed

Dependencies added: base, binary, bytestring, containers, exceptions, hedis, mtl, numeric-limits, random, text, time, uuid

Files

• CHANGELOG.md +3/−0
• LICENSE +30/−0
• README.md +922/−0
• Setup.hs +2/−0
• redis-schema.cabal +54/−0
• src/Database/Redis/Schema.hs +1244/−0
• src/Database/Redis/Schema/Lock.hs +354/−0

@@ -0,0 +1,3 @@+# v0.1++First public version of `redis-schema`.

@@ -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.

@@ -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.++<!--+vim: ts=2 sts=2 sw=2 et+-->

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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

@@ -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 <TheType>@.+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:+      --   <length1>,<length2>,...,<lengthN>:<string1>:<string2>:...:<stringN>+      --+      -- 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"

@@ -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)