packages feed

keyed-vals-redis (empty) → 0.1.0.0

raw patch · 8 files changed

+530/−0 lines, 8 filesdep +QuickCheckdep +basedep +bytestringsetup-changed

Dependencies added: QuickCheck, base, bytestring, containers, hedis, hspec, hspec-tmp-proc, keyed-vals, keyed-vals-hspec-tests, keyed-vals-redis, read-env-var, text, tmp-proc-redis, unliftio, unliftio-core

Files

+ ChangeLog.md view
@@ -0,0 +1,9 @@+# Revision history for keyed-vals++`keyed-vals-redis` uses [PVP Versioning][1].++## 0.1.0.0 -- 2022-11-28++* Initial version.++[1]: https://pvp.haskell.org
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2022, Tim Emiola++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 Tim Emiola 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.
+ README.md view
@@ -0,0 +1,21 @@+# keyed-vals-redis++[![GitHub CI](https://github.com/adetokunbo/keyed-vals/actions/workflows/ci.yml/badge.svg)](https://github.com/adetokunbo/keyed-vals/actions)+[![Stackage Nightly](http://stackage.org/package/keyed-vals-redis/badge/nightly)](http://stackage.org/nightly/package/keyed-vals-redis)+[![Hackage][hackage-badge]][hackage]+[![Hackage Dependencies][hackage-deps-badge]][hackage-deps]+[![BSD3](https://img.shields.io/badge/license-BSD3-green.svg?dummy)](https://github.com/adetokunbo/keyed-vals-redis/blob/master/LICENSE)++`keyed-vals` aims to provide a narrow client for storing key-value collections+in storage services like [Redis] via an abstract [Handle] interface.++This package, `keyed-vals-redis`, provides an implementation of the [Handle]+that uses [Redis] as the storage service.+++[hackage-deps-badge]: <https://img.shields.io/hackage-deps/v/keyed-vals-redis.svg>+[hackage-deps]:       <http://packdeps.haskellers.com/feed?needle=keyed-vals-redis>+[hackage-badge]:      <https://img.shields.io/hackage/v/keyed-vals-redis.svg>+[hackage]:            <https://hackage.haskell.org/package/keyed-vals-redis>+[Handle]:             <https://hackage.haskell.org/package/keyed-vals>+[Redis]:              <https://redis.io>
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple+++main = defaultMain
+ keyed-vals-redis.cabal view
@@ -0,0 +1,66 @@+cabal-version:      3.0+name:               keyed-vals-redis+version:            0.1.0.0+license:            BSD-3-Clause+license-file:       LICENSE+maintainer:         adetokunbo@emio.la+author:             Tim Emiola+tested-with:        GHC ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.1+homepage:           https://github.com/adetokunbo/keyed-vals#readme+bug-reports:        https://github.com/adetokunbo/keyed-vals/issues+synopsis:+  Access Redis using a keyed-vals Handle++description:+  [keyed-vals](https://hackage.haskell.org/package/keyed-vals) specifies+  a focussed client of storage services like [Redis](https://redis.io).++  I.e, while Redis supports many features; the abstract Handle in keyed-vals+  just supports operations that access collections of key-values++  This package provides a concrete implementation of Handle that uses Redis as+  the underlying storage service.++category:           Data, Redis+build-type:         Simple+extra-source-files:+  ChangeLog.md+  README.md++source-repository head+  type:     git+  location: https://github.com/adetokunbo/keyed-vals.git++library+  exposed-modules:  KeyedVals.Handle.Redis+  other-modules:    KeyedVals.Handle.Redis.Internal+  hs-source-dirs:   src+  default-language: Haskell2010+  ghc-options:      -Wall -Wincomplete-uni-patterns -fwarn-tabs+  build-depends:+    , base           >=4.11     && <5.0+    , bytestring     >=0.10.8.2 && <0.11 || >=0.11.3.1 && <0.12+    , containers     >=0.6.5    && <0.7+    , hedis          >= 0.15.1  && < 0.16+    , keyed-vals     >=0.1      && <0.2+    , read-env-var   >= 1.0.0   && < 1.1+    , text           >=1.2.4    && <1.3  || >=2.0+    , unliftio       >=0.2.22   && <0.3+    , unliftio-core  >=0.2.0    && <0.3+++test-suite integration-test+  type:             exitcode-stdio-1.0+  main-is:          Spec.hs+  hs-source-dirs:   test+  build-depends:    base+                  , QuickCheck+                  , keyed-vals-hspec-tests+                  , keyed-vals-redis+                  , bytestring+                  , hspec+                  , hspec-tmp-proc+                  , tmp-proc-redis+                  , text+  default-language: Haskell2010+  ghc-options:      -threaded -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs
+ src/KeyedVals/Handle/Redis.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_HADDOCK prune not-home #-}++{- |+Copyright   : (c) 2018-2022 Tim Emiola+SPDX-License-Identifier: BSD3+Maintainer  : Tim Emiola <tim@emio.la>++Implements a 'Handle' that uses Redis as a persistent data store.+-}+module KeyedVals.Handle.Redis (+  -- * create a Handle+  new,++  -- * module re-exports+  module KeyedVals.Handle,+) where++import Control.Monad.IO.Unlift (MonadUnliftIO, liftIO)+import KeyedVals.Handle+import KeyedVals.Handle.Redis.Internal+import UnliftIO.Exception (throwIO)+++{- | Construct a 'Handle' that uses Redis.++The instance is configured using the environment variable @REDIS_URL@.++If the value of @REDIS_URL@ is invalid or missing, this function throws an IOError.++The Handle uses a pool of connections; the size of the pool can be adjusted+by setting the environment variable @REDIS_MAX_CONNECTIONS@.+-}+new :: MonadUnliftIO m => m (Handle m)+new =+  liftIO readEnvConnectInfo >>= \case+    (Just i) -> fromConnectInfo i+    Nothing -> liftIO $ throwIO $ userError "could not create a Handle that uses redis"
+ src/KeyedVals/Handle/Redis/Internal.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK prune not-home #-}++{- |+Copyright   : (c) 2018-2022 Tim Emiola+SPDX-License-Identifier: BSD3+Maintainer  : Tim Emiola <tim@emio.la>++Provides a 'Handle' that stores data in Redis.+-}+module KeyedVals.Handle.Redis.Internal (+  -- * Handle creation+  fromConnectInfo,++  -- * Configuration+  readEnvConnectInfo,++  -- * module re-exports+  module KeyedVals.Handle,+) where++import Control.Exception (throwIO)+import Control.Monad.IO.Unlift (MonadIO, MonadUnliftIO, liftIO)+import qualified Data.ByteString as B+import Data.Functor ((<&>))+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map.Strict as Map+import Data.Maybe (mapMaybe)+import qualified Data.Text as Text+import Data.Text.Encoding (decodeUtf8)+import Database.Redis (+  ConnectInfo (..),+  Connection,+  Redis,+  Reply (..),+  Status (..),+  checkedConnect,+  del,+  disconnect,+  get,+  hdel,+  hget,+  hgetall,+  hkeys,+  hlen,+  hmget,+  hmset,+  hset,+  keys,+  parseConnectInfo,+  runRedis,+  set,+ )+import KeyedVals.Handle+import KeyedVals.Handle.Internal (Handle (..))+import Numeric.Natural (Natural)+import System.ReadEnvVar (lookupEnv, readEnvDef)+++-- | Determine 'ConnectInfo' from the environment.+readEnvConnectInfo :: IO (Maybe ConnectInfo)+readEnvConnectInfo = do+  maxConns <- readEnvDef "REDIS_MAX_CONNECTIONS" fallbackMaxConns+  lookupEnv "REDIS_URL" >>= maybe (pure Nothing) (parseLocator maxConns)+++-- | Obtain a @ConnectInfo@ from a Redis Url and max connections+parseLocator :: Int -> String -> IO (Maybe ConnectInfo)+parseLocator maxConns l = do+  let parseConnectInfo' = either invalidLocator pure . parseConnectInfo+      setMaxConns x cfg = cfg {connectMaxConnections = x}+  Just . setMaxConns maxConns <$> parseConnectInfo' l+++invalidLocator :: String -> IO a+invalidLocator x = throwIO $ userError $ "REDIS connection url: " ++ x ++ " is invalid"+++-- | Create a 'Handle'.+fromConnectInfo :: MonadUnliftIO m => ConnectInfo -> m (Handle m)+fromConnectInfo connectInfo = do+  conn <- liftIO $ checkedConnect connectInfo+  pure $+    Handle+      { hClose = hClose' conn+      , hLoadVal = hLoadVal' conn+      , hSaveVal = hSaveVal' conn+      , hLoadKVs = hLoadKVs' conn+      , hSaveKVs = hSaveKVs' conn+      , hUpdateKVs = hUpdateKVs' conn+      , hLoadFrom = hLoadFrom' conn+      , hLoadSlice = hLoadSlice' conn+      , hSaveTo = hSaveTo' conn+      , hDeleteSelected = hDeleteSelected' conn+      , hDeleteSelectedKVs = hDeleteSelectedKVs' conn+      , hCountKVs = hCountKVs' conn+      }+++hClose' :: MonadUnliftIO m => Connection -> m ()+hClose' = liftIO . disconnect+++hLoadVal' ::+  MonadUnliftIO m =>+  Connection ->+  Key ->+  m (Either HandleErr (Maybe Val))+hLoadVal' conn key = doFetch conn $ get key+++hSaveVal' ::+  MonadUnliftIO m =>+  Connection ->+  Key ->+  Val ->+  m (Either HandleErr ())+hSaveVal' conn key value = doStore conn $ set key value+++hLoadFrom' ::+  MonadUnliftIO m =>+  Connection ->+  Key ->+  Key ->+  m (Either HandleErr (Maybe Val))+hLoadFrom' conn key dictKey = doFetch conn $ hget key dictKey+++hLoadKVs' ::+  MonadUnliftIO m =>+  Connection ->+  Key ->+  m (Either HandleErr ValsByKey)+hLoadKVs' conn key = doFetch conn $ hgetall key <&> fmap Map.fromList+++hLoadSlice' ::+  MonadUnliftIO m =>+  Connection ->+  Key ->+  Selection ->+  m (Either HandleErr ValsByKey)+hLoadSlice' conn key m@(Match _) = selectKeysThen hLoadSlice' conn key m+hLoadSlice' conn key (AllOf dictKeys') = do+  let dictKeys = NonEmpty.toList dictKeys'+  doFetch conn (hmget key dictKeys) >>= \case+    Left err -> pure $ Left err+    Right fetched -> do+      let pairedMaybes = zip dictKeys fetched+          mbOf (x, mbY) = mbY >>= \y -> Just (x, y)+      pure $ Right $ Map.fromList $ mapMaybe mbOf pairedMaybes+++hCountKVs' ::+  MonadUnliftIO m =>+  Connection ->+  Key ->+  m (Either HandleErr Natural)+hCountKVs' conn key = doFetch conn $ hlen key <&> fmap fromInteger+++hSaveTo' ::+  MonadUnliftIO m =>+  Connection ->+  Key ->+  Key ->+  Val ->+  m (Either HandleErr ())+hSaveTo' conn key dictKey value = doStore' conn $ hset key dictKey value+++hSaveKVs' ::+  MonadUnliftIO m =>+  Connection ->+  Key ->+  ValsByKey ->+  m (Either HandleErr ())+hSaveKVs' conn key dict = do+  _ <- hDeleteSelected' conn $ AllOf (key :| [])+  hUpdateKVs' conn key dict+++hUpdateKVs' ::+  MonadUnliftIO m =>+  Connection ->+  Key ->+  ValsByKey ->+  m (Either HandleErr ())+hUpdateKVs' conn key dict = doStore' conn $ hmset key $ Map.toList dict+++hDeleteSelected' ::+  MonadUnliftIO m =>+  Connection ->+  Selection ->+  m (Either HandleErr ())+hDeleteSelected' conn (AllOf ks) = doStore' conn $ del $ NonEmpty.toList ks+hDeleteSelected' conn (Match g) = do+  doFetch conn (keys $ globPattern g) >>= \case+    Left e -> pure $ Left e+    Right [] -> pure $ Right ()+    Right (k : ks) -> hDeleteSelected' conn $ AllOf (k :| ks)+++hDeleteSelectedKVs' ::+  MonadUnliftIO m =>+  Connection ->+  Key ->+  Selection ->+  m (Either HandleErr ())+hDeleteSelectedKVs' conn key (AllOf dictKeys) = doStore' conn $ hdel key $ NonEmpty.toList dictKeys+hDeleteSelectedKVs' conn key m@(Match _) = selectKeysThen hDeleteSelectedKVs' conn key m+++selectKeysThen ::+  (Monoid b, MonadUnliftIO m) =>+  (Connection -> B.ByteString -> Selection -> m (Either HandleErr b)) ->+  Connection ->+  B.ByteString ->+  Selection ->+  m (Either HandleErr b)+selectKeysThen f conn key selection = do+  (doFetch conn $ hkeys key) >>= \case+    Left e -> pure $ Left e+    Right [] -> pure $ Right mempty+    Right xs -> do+      case (filter (\k -> k `isIn` selection) xs) of+        [] -> pure $ Right mempty+        (k : ks) -> f conn key $ AllOf (k :| ks)+++fallbackMaxConns :: Int+fallbackMaxConns = 10+++toHandleErr :: Reply -> HandleErr+toHandleErr (Error e) | B.isPrefixOf "WRONGTYPE" e = BadKey+toHandleErr (Error e) = Unanticipated $ decodeUtf8 e+toHandleErr r = Unanticipated $ Text.pack $ show r+++doStore ::+  MonadIO m =>+  Connection ->+  Redis (Either Reply Status) ->+  m (Either HandleErr ())+doStore conn action = liftIO $ leftErr $ runRedis conn action+++leftErr :: Monad m => m (Either Reply Status) -> m (Either HandleErr ())+leftErr x =+  x >>= \case+    (Left l) -> pure $ Left $ toHandleErr l+    Right Ok -> pure $ Right ()+    Right Pong -> pure $ Right ()+    Right (Status err) -> pure $ Left $ Unanticipated $ Text.pack $ show err+++doStore' ::+  MonadIO m =>+  Connection ->+  Redis (Either Reply a) ->+  m (Either HandleErr ())+doStore' conn action = liftIO $ leftErr'' $ runRedis conn action+++leftErr'' :: Monad m => m (Either Reply a) -> m (Either HandleErr ())+leftErr'' x =+  x >>= \case+    (Left l) -> pure $ Left $ toHandleErr l+    Right _ -> pure $ Right ()+++doFetch ::+  MonadUnliftIO m =>+  Connection ->+  Redis (Either Reply a) ->+  m (Either HandleErr a)+doFetch conn = liftIO . leftErr' . runRedis conn+++leftErr' :: Monad m => m (Either Reply a) -> m (Either HandleErr a)+leftErr' = (<&> either (Left . toHandleErr) Right)
+ test/Spec.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_HADDOCK prune not-home #-}++{- |+Copyright   : (c) 2022 Tim Emiola+Maintainer  : Tim Emiola <adetokunbo@emio.la>+SPDX-License-Identifier: BSD3+-}+module Main where++import Control.Exception (onException)+import Data.ByteString.Char8 (unpack)+import Data.Proxy (Proxy (..))+import KeyedVals.Handle.Redis (Handle, new)+import System.Environment (setEnv)+import System.IO (+  BufferMode (..),+  hSetBuffering,+  stderr,+  stdout,+ )+import System.TmpProc.Docker.Redis+import Test.Hspec (hspec, mapSubject)+import Test.Hspec.TmpProc+import Test.KeyedVals.Hspec (+  Spec,+  afterAll,+  beforeAll,+  checkHandle,+  closeFixture,+  setupFixture,+ )+++main :: IO ()+main = do+  hSetBuffering stdout NoBuffering+  hSetBuffering stderr NoBuffering+  hspec spec+++spec :: Spec+spec =+  tdescribe "Using a redis Handle" $+    beforeAll setupHandles $+      afterAll closeHandles $+        mapSubject fst checkHandle+++setupHandles :: IO (Fixture (HList '[ProcHandle TmpRedis]))+setupHandles = do+  procHandles <- startupAll $ testProc `HCons` HNil+  flip onException (terminateAll procHandles) $ do+    let redisUrl = unpack $ hUri $ handleOf @"a-redis-db" Proxy procHandles+        addProcHandles x = (x, procHandles)+    setEnv "REDIS_URL" redisUrl+    h <- new+    addProcHandles <$> setupFixture h+++closeHandles :: Fixture (HList '[ProcHandle TmpRedis]) -> IO ()+closeHandles f = do+  closeFixture $ fst f+  terminateAll $ snd f+++type Fixture a = (Handle IO, a)+++testProc :: TmpRedis+testProc = TmpRedis []