persistent-redis 2.5.2.2 → 2.5.2.5

raw patch · 8 files changed

+112/−117 lines, 8 filesdep −attoparsecdep −monad-controldep ~aesondep ~basedep ~binarynew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: attoparsec, monad-control

Dependency ranges changed: aeson, base, binary, bytestring, hedis, mtl, path-pieces, persistent, persistent-template, scientific, text, time, transformers, utf8-string

API changes (from Hackage documentation)

Files

• Database/Persist/Redis/Config.hs +12/−20
• Database/Persist/Redis/Exception.hs +1/−3
• Database/Persist/Redis/Internal.hs +10/−10
• Database/Persist/Redis/Parser.hs +16/−15
• Database/Persist/Redis/Store.hs +17/−18
• Database/Persist/Redis/Update.hs +4/−5
• persistent-redis.cabal +34/−36
• tests/basic-test.hs +18/−10

@@ -1,10 +1,7 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes, TypeFamilies, GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-orphans #-}+ module Database.Persist.Redis.Config     ( RedisAuth (..)     , RedisConf (..)@@ -19,23 +16,18 @@     , module Database.Persist     ) where -import Database.Persist-import qualified Database.Redis as R-import Data.Text (Text, unpack, pack)-import Data.Aeson (Value (Object, Number, String), (.:?), (.!=), FromJSON(..))-import Control.Monad (mzero, MonadPlus(..)) import Control.Monad.IO.Class (MonadIO (..))--- import Control.Monad.Trans.Class (MonadTrans (..))--- import Control.Applicative (Applicative (..)) import Control.Monad.Reader(ReaderT(..)) import Control.Monad.Reader.Class+import Data.Aeson (Value (Object, Number, String), (.:?), (.!=), FromJSON(..)) import qualified Data.ByteString.Char8 as B-#if MIN_VERSION_aeson(0, 7, 0)+import Control.Monad (mzero, MonadPlus(..)) import Data.Scientific() -- we require only RealFrac instance of Scientific-#else-import Data.Attoparsec.Number-#endif+import Data.Text (Text, unpack, pack)+import qualified Database.Redis as R +import Database.Persist+ newtype RedisAuth =  RedisAuth Text deriving (Eq, Show)  -- | Information required to connect to a Redis server@@ -62,7 +54,7 @@ thisConnection = ask  -- | Run a connection reader function against a Redis configuration-withRedisConn :: (Monad m, MonadIO m) => RedisConf -> (R.Connection -> m a) -> m a+withRedisConn :: (MonadIO m) => RedisConf -> (R.Connection -> m a) -> m a withRedisConn conf connectionReader = do     conn <- liftIO $ createPoolConfig conf     connectionReader conn@@ -89,14 +81,14 @@      loadConfig _ = mzero -    createPoolConfig (RedisConf h p Nothing m) = +    createPoolConfig (RedisConf h p Nothing m) =         R.connect $         R.defaultConnectInfo {             R.connectHost = unpack h,             R.connectPort = p,             R.connectMaxConnections = m         }-    createPoolConfig (RedisConf h p (Just (RedisAuth pwd)) m) = +    createPoolConfig (RedisConf h p (Just (RedisAuth pwd)) m) =         R.connect $         R.defaultConnectInfo {             R.connectHost = unpack h,

@@ -1,9 +1,7 @@-{-# LANGUAGE DeriveDataTypeable #-} module Database.Persist.Redis.Exception     ( RedisException (..)     ) where -import Data.Typeable (Typeable) import Control.Exception (Exception)  data RedisException = NotSupportedOperation String@@ -11,7 +9,7 @@                     | NotSupportedValueType String                     | IncorrectUpdate String                     | IncorrectBehavior-    deriving Typeable+ instance Show RedisException where     show (NotSupportedOperation key) = "The operation is not supported: " ++ key     show (ParserError msg) = "Error during parsing: " ++ msg

@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} module Database.Persist.Redis.Internal     ( toKey     , unKey@@ -9,13 +8,14 @@     , toB     ) where -import Data.Text (Text, unpack)-import qualified Data.Text as T-import Database.Persist.Types-import Database.Persist.Class import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as U+import Data.Text (Text, unpack)+import qualified Data.Text as T+import Control.Monad.Fail (MonadFail) +import Database.Persist.Class+import Database.Persist.Types import Database.Persist.Redis.Parser  toLabel :: FieldDef -> B.ByteString@@ -27,7 +27,7 @@ toEntityName :: EntityDef -> B.ByteString toEntityName = U.fromString . unpack . unDBName . entityDB -mkEntity :: (Monad m, PersistEntity val) => Key val -> [(B.ByteString, B.ByteString)] -> m (Entity val)+mkEntity :: (MonadFail m, PersistEntity val) => Key val -> [(B.ByteString, B.ByteString)] -> m (Entity val) mkEntity key fields = do     let values = redisToPerisistValues fields     let v = fromPersistValues values@@ -39,7 +39,7 @@ zipAndConvert :: PersistField t => [FieldDef] -> [t] -> [(B.ByteString, B.ByteString)] zipAndConvert [] _ = [] zipAndConvert _ [] = []-zipAndConvert (e:efields) (p:pfields) = +zipAndConvert (e:efields) (p:pfields) =     let pv = toPersistValue p     in         if pv == PersistNull then zipAndConvert efields pfields@@ -57,7 +57,7 @@  -- | Make a key for given entity and id toKeyText :: PersistEntity val => val -> Integer -> Text-toKeyText val k = T.append (T.append (toEntityString val) "_") (T.pack $ show k)+toKeyText val k = toEntityString val `T.append` T.pack "_" `T.append` T.pack (show k)  toB :: Text -> B.ByteString toB = U.fromString . unpack@@ -76,8 +76,8 @@ unKey :: (PersistEntity val) => Key val -> B.ByteString unKey = toValue . head . keyToValues -toKey :: (Monad m, PersistEntity val) => Text -> m (Key val)-toKey x = case q of +toKey :: (Monad m, MonadFail m, PersistEntity val) => Text -> m (Key val)+toKey x = case q of         Right z -> return z         Left a -> fail (unpack a)     where

@@ -1,22 +1,22 @@-module Database.Persist.Redis.Parser +module Database.Persist.Redis.Parser     ( redisToPerisistValues     , toValue     ) where -import Data.Fixed-import Data.Time-import Data.Int (Int64)-import Data.Word (Word8)-import Data.Text (Text, unpack)-import qualified Data.Text as T+import Control.Arrow((***))+import Control.Monad (liftM, liftM3)+import Control.Exception (throw) import Data.Binary (Binary(..), encode, getWord8, Get) import qualified Data.Binary as Q import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.UTF8 as U-import Control.Arrow((***))-import Control.Monad (liftM, liftM3)-import Control.Exception (throw)+import Data.Fixed+import Data.Int (Int64)+import Data.Text (Text, unpack)+import qualified Data.Text as T+import Data.Time+import Data.Word (Word8)  import Database.Persist.Types import Database.Persist.Redis.Exception@@ -24,11 +24,11 @@ newtype BinText = BinText { unBinText :: Text } instance Binary BinText where     put = put . U.fromString . unpack . unBinText-    get = do +    get = do         str <- Q.get         return $ BinText $ (T.pack . U.toString) str -newtype BinPico= BinPico { unBinPico :: Pico } +newtype BinPico= BinPico { unBinPico :: Pico } instance Binary BinPico where     put = put . toRational . unBinPico     get = do@@ -60,7 +60,7 @@         let tod = liftM3 TimeOfDay (Q.get :: Get Int) (Q.get :: Get Int) s         liftM BinTimeOfDay tod -{-  +{- newtype BinZT = BinZT { unBinZT :: ZT } instance Binary BinZT where     put (BinZT (ZT (ZonedTime (LocalTime day timeOfDay) (TimeZone mins summer name)))) = do@@ -96,7 +96,7 @@         put (4 :: Word8)         put x -    put (BinPersistValue (PersistBool x)) = do +    put (BinPersistValue (PersistBool x)) = do         put (5 :: Word8)         put x @@ -114,7 +114,7 @@         put (BinDiffTime pc)      put (BinPersistValue PersistNull) = put (9 :: Word8)-    put (BinPersistValue (PersistList x)) = do +    put (BinPersistValue (PersistList x)) = do         put (10 :: Word8)         put (map BinPersistValue x) @@ -126,6 +126,7 @@         put (12 :: Word8)         put x +    put (BinPersistValue (PersistArray _)) = throw $ NotSupportedValueType "PersistArray"     put (BinPersistValue (PersistDbSpecific _)) = throw $ NotSupportedValueType "PersistDbSpecific"     put (BinPersistValue (PersistObjectId _)) = throw $ NotSupportedValueType "PersistObjectId" 

@@ -1,25 +1,24 @@-{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.Redis.Store     ( execRedisT     , RedisBackend     )where -import Database.Persist import Control.Monad.IO.Class (MonadIO (..))-import qualified Database.Persist.Sql as Sql-import qualified Database.Redis as R+import Data.Aeson(FromJSON(..), ToJSON(..)) import Data.Text (Text, pack)+import qualified Database.Redis as R+import Web.HttpApiData (ToHttpApiData (..), FromHttpApiData (..), parseUrlPieceMaybe)+import Web.PathPieces (PathPiece(..))++import Database.Persist import Database.Persist.Redis.Config (RedisT, thisConnection) import Database.Persist.Redis.Internal import Database.Persist.Redis.Update-import Web.PathPieces (PathPiece(..))-import Web.HttpApiData (ToHttpApiData (..), FromHttpApiData (..), parseUrlPieceMaybe)--import Data.Aeson(FromJSON(..), ToJSON(..))+import qualified Database.Persist.Sql as Sql  type RedisBackend = R.Connection @@ -35,14 +34,14 @@ desugar (R.TxError string) = Left string  -- | Execute Redis transaction inside RedisT monad transformer-execRedisT :: (Monad m, MonadIO m) => R.RedisTx (R.Queued a) -> RedisT m a+execRedisT :: (MonadIO m) => R.RedisTx (R.Queued a) -> RedisT m a execRedisT action = do     conn <- thisConnection     result <- liftIO $ R.runRedis conn $ R.multiExec action -- this is the question if we should support transaction here     let r = desugar result     case r of         (Right x) -> return x-        (Left x)  -> fail x+        (Left x)  -> liftIO $ fail x  instance HasPersistBackend R.Connection where   type BaseBackend R.Connection = R.Connection@@ -58,14 +57,14 @@         if null r             then return Nothing             else do-                Entity _ val <- mkEntity k r+                Entity _ val <- liftIO $ mkEntity k r                 return $ Just val  instance PersistStoreWrite R.Connection where     insert val = do         keyId <- execRedisT $ createKey val         let textKey = toKeyText val keyId-        key <- toKey textKey+        key <- liftIO $ toKey textKey         _ <- insertKey key val         return key @@ -88,17 +87,17 @@     delete k = do         r <- execRedisT $ R.del [unKey k]         case r of-            0 -> fail "there is no such key!"+            0 -> liftIO $ fail "there is no such key!"             1 -> return ()-            _ -> fail "there are a lot of such keys!"+            _ -> liftIO $ fail "there are a lot of such keys!"      update _ [] = return ()     update k upds = do         r <- execRedisT $ R.hgetall (unKey k)         if null r-            then fail "No such key exists!"+            then pure ()             else do-                v <- mkEntity k r+                v <- liftIO $ mkEntity k r                 let (Entity _ val) = cmdUpdate v upds                 insertKey k val         return()

@@ -1,12 +1,11 @@-{-# LANGUAGE RankNTypes #-} module Database.Persist.Redis.Update     ( cmdUpdate     ) where  import Control.Exception (throw)+import Data.Either() import Data.Functor.Identity import Data.Functor.Constant-import Data.Either ()  import Database.Persist import Database.Persist.Redis.Exception@@ -27,15 +26,15 @@ updateOneField :: PersistEntity val => Update val -> Entity val -> Entity val updateOneField (BackendUpdate _) _ =  throw $ NotSupportedOperation "Backend specific update" updateOneField (Update field v Assign) oldValue  = set (fieldLens field) v oldValue-updateOneField (Update _ _ (BackendSpecificUpdate _)) _ = +updateOneField (Update _ _ (BackendSpecificUpdate _)) _ =     throw $ NotSupportedOperation "Backend specific update withing update operation"  updateOneField (Update field v up) oldValue  = set (fieldLens field) newValue oldValue-    where +    where         lens = fieldLens field         pv    = toPersistValue v         oldV = toPersistValue $ view oldValue lens-        eitherNewValue = fromPersistValue $ apply up oldV pv +        eitherNewValue = fromPersistValue $ apply up oldV pv         newValue = either (\_ -> throw IncorrectBehavior) id eitherNewValue  

@@ -1,5 +1,5 @@ name:            persistent-redis-version:         2.5.2.2+version:         2.5.2.5 license:         BSD3 license-file:    LICENSE author:          Pavel Ryzhov <paul@paulrz.cz>@@ -7,7 +7,7 @@ description:     Based on the Redis package. category:        Database stability:       Experimental-cabal-version:   >= 1.8+cabal-version:   >= 1.10 maintainer:      Pavel Ryzhov <paul@paulrz.cz> build-type:      Simple bug-reports:     https://github.com/yesodweb/persistent/issues@@ -17,56 +17,53 @@         location:       https://github.com/yesodweb/persistent.git  library-    build-depends:   base                  >= 4.6        && < 5-                   , hedis                 >= 0.6.0-                   , bytestring            >= 0.10.0.0 && < 0.11.0.0+    build-depends:   base                  >= 4.9        && < 5                    , persistent            >= 2.5      && < 3.0-                   , text                  >= 1.2.0.0-                   , aeson                 >= 0.8-                   , time                  >= 1.4-                   , attoparsec            >= 0.12.0.0-                   , mtl                   >= 2.2.0    && < 2.3-                   , transformers          >= 0.4.0.0  && < 0.6.0.0-                   , monad-control         >= 0.3.2.0  && < 1.2.0.0-                   , utf8-string           >= 0.3.7    && < 1.1.0-                   , binary                >= 0.7      && < 0.9-                   , scientific            >= 0.3.1    && < 0.4-                   , path-pieces           >= 0.1+                   , aeson                 >= 1.0+                   , binary                >= 0.8      && < 0.9+                   , bytestring            >= 0.10.8   && < 0.11+                   , hedis                 >= 0.9                    , http-api-data+                   , mtl                   >= 2.2.1    && < 2.3+                   , path-pieces           >= 0.2+                   , scientific            >= 0.3.5    && < 0.4+                   , text                  >= 1.2+                   , time                  >= 1.6+                   , transformers          >= 0.5         && < 0.6+                   , utf8-string           >= 1.0         && < 1.1      exposed-modules: Database.Persist.Redis      other-modules:   Database.Persist.Redis.Config+                     Database.Persist.Redis.Exception                      Database.Persist.Redis.Internal-                     Database.Persist.Redis.Store                      Database.Persist.Redis.Parser+                     Database.Persist.Redis.Store                      Database.Persist.Redis.Update-                     Database.Persist.Redis.Exception      ghc-options:     -Wall+    default-language: Haskell2010  test-suite  basic     type: exitcode-stdio-1.0     main-is: tests/basic-test.hs-    build-depends:   base                  >= 4.6        && < 5-                   , hedis                 >= 0.6.0-                   , persistent            >= 2.5      && < 3.0-                   , persistent-template   >= 2.5      && < 3.0-                   , mtl                   >= 2.2.0    && < 2.3-                   , transformers          >= 0.4.0.0  && < 0.6.0.0-                   , utf8-string           >= 0.3.7    && < 1.1.0-                   , bytestring            >= 0.10.0.0 && < 0.11.0.0-                   , text                  >= 1.2.0.0-                   , aeson                 >= 0.8-                   , binary                >= 0.7      && < 0.9-                   , time                  >= 1.4-                   , attoparsec            >= 0.12.0.0-                   , template-haskell-                   , monad-control         >= 0.3.2.0  && < 1.2.0.0-                   , path-pieces           >= 0.1-                   , scientific-                   , http-api-data+    build-depends:   base                  >= 4.9      && < 5+                   , persistent            >= 2.10     && < 3.0                    , persistent-redis+                   , persistent-template   >= 2.7      && < 3.0+                   , aeson                 >= 1.0+                   , bytestring            >= 0.10.8   && < 0.11+                   , binary                >= 0.8      && < 0.9+                   , hedis                 >= 0.9+                   , http-api-data+                   , mtl                   >= 2.2.1    && < 2.3+                   , path-pieces           >= 0.2+                   , scientific+                   , template-haskell+                   , text                  >= 1.2+                   , time                  >= 1.6+                   , transformers          >= 0.5      && < 0.6+                   , utf8-string           >= 1.0      && < 1.1      other-modules:   Database.Persist.Redis                      Database.Persist.Redis.Config@@ -75,3 +72,4 @@                      Database.Persist.Redis.Parser                      Database.Persist.Redis.Update                      Database.Persist.Redis.Exception+    default-language: Haskell2010

@@ -1,18 +1,26 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}-{-# LANGUAGE TypeFamilies, EmptyDataDecls, GADTs #-}-{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-} module Main where +import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Text (Text, pack, unpack) import qualified Database.Redis as R+import Language.Haskell.TH.Syntax+ import Database.Persist import Database.Persist.Redis import Database.Persist.TH-import Language.Haskell.TH.Syntax-import Control.Monad.IO.Class (liftIO)-import Data.Text (Text, pack, unpack)  let redisSettings = mkPersistSettings (ConT ''RedisBackend)- in share [mkPersist redisSettings] [persistLowerCase| + in share [mkPersist redisSettings] [persistLowerCase| Person     name String     age Int@@ -28,13 +36,13 @@ redisConf :: RedisConf redisConf = RedisConf host (R.connectPort d) Nothing 10 -mkKey :: (Monad m, PersistEntity val) => Text -> m (Key val)+mkKey :: (MonadIO m, PersistEntity val) => Text -> m (Key val) mkKey s = case keyFromValues [PersistText s] of     Right z -> return z-    Left  a -> fail (unpack a)+    Left  a -> liftIO $ fail (unpack a)  main :: IO ()-main = +main =     withRedisConn redisConf $ runRedisPool $ do         _ <- liftIO $ print "Inserting..."         s <- insert $ Person "Test" 12