diff --git a/Database/Persist/Redis/Config.hs b/Database/Persist/Redis/Config.hs --- a/Database/Persist/Redis/Config.hs +++ b/Database/Persist/Redis/Config.hs @@ -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, diff --git a/Database/Persist/Redis/Exception.hs b/Database/Persist/Redis/Exception.hs --- a/Database/Persist/Redis/Exception.hs +++ b/Database/Persist/Redis/Exception.hs @@ -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 diff --git a/Database/Persist/Redis/Internal.hs b/Database/Persist/Redis/Internal.hs --- a/Database/Persist/Redis/Internal.hs +++ b/Database/Persist/Redis/Internal.hs @@ -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 diff --git a/Database/Persist/Redis/Parser.hs b/Database/Persist/Redis/Parser.hs --- a/Database/Persist/Redis/Parser.hs +++ b/Database/Persist/Redis/Parser.hs @@ -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" diff --git a/Database/Persist/Redis/Store.hs b/Database/Persist/Redis/Store.hs --- a/Database/Persist/Redis/Store.hs +++ b/Database/Persist/Redis/Store.hs @@ -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() diff --git a/Database/Persist/Redis/Update.hs b/Database/Persist/Redis/Update.hs --- a/Database/Persist/Redis/Update.hs +++ b/Database/Persist/Redis/Update.hs @@ -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 diff --git a/persistent-redis.cabal b/persistent-redis.cabal --- a/persistent-redis.cabal +++ b/persistent-redis.cabal @@ -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 @@ -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 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 diff --git a/tests/basic-test.hs b/tests/basic-test.hs --- a/tests/basic-test.hs +++ b/tests/basic-test.hs @@ -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