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 @@ -12,7 +12,7 @@ , R.Redis , R.Connection , R.PortID (..) - , RedisT (..) + , RedisT , runRedisPool , withRedisConn , thisConnection @@ -25,8 +25,8 @@ 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.Trans.Class (MonadTrans (..)) +-- import Control.Applicative (Applicative (..)) import Control.Monad.Reader(ReaderT(..)) import Control.Monad.Reader.Class import qualified Data.ByteString.Char8 as B @@ -55,12 +55,11 @@ parseJSON _ = fail "couldn't parse auth" -- | Monad reader transformer keeping Redis connection through out the work -newtype RedisT m a = RedisT { runRedisT :: ReaderT R.Connection m a } - deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadPlus) +type RedisT = ReaderT R.Connection -- | Extracts connection from RedisT monad transformer thisConnection :: Monad m => RedisT m R.Connection -thisConnection = RedisT ask +thisConnection = ask -- | Run a connection reader function against a Redis configuration withRedisConn :: (Monad m, MonadIO m) => RedisConf -> (R.Connection -> m a) -> m a @@ -69,7 +68,7 @@ connectionReader conn runRedisPool :: RedisT m a -> R.Connection -> m a -runRedisPool (RedisT r) = runReaderT r +runRedisPool r = runReaderT r instance PersistConfig RedisConf where type PersistConfigBackend RedisConf = RedisT 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 @@ -6,6 +6,8 @@ , toKeyText , toB , mkEntity + , unKey + , toKey ) where import Control.Arrow((***)) @@ -24,13 +26,13 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.UTF8 as U -toLabel :: FieldDef a -> B.ByteString +toLabel :: FieldDef -> B.ByteString toLabel = U.fromString . unpack . unDBName . fieldDB toEntityString :: PersistEntity val => val -> Text toEntityString = unDBName . entityDB . entityDef . Just -toEntityName :: EntityDef a -> B.ByteString +toEntityName :: EntityDef -> B.ByteString toEntityName = U.fromString . unpack . unDBName . entityDB newtype BinText = BinText { unBinText :: Text } @@ -72,6 +74,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 @@ -88,7 +91,7 @@ summer <- Q.get :: Get Bool name <- Q.get :: Get String return $ BinZT $ ZT (ZonedTime (LocalTime (unBinDay day) (unBinTimeOfDay timeOfDay)) (TimeZone mins summer name)) - +-} newtype BinPersistValue = BinPersistValue { unBinPersistValue :: PersistValue } instance Binary BinPersistValue where put (BinPersistValue (PersistText x)) = do @@ -137,10 +140,6 @@ put (12 :: Word8) put x - put (BinPersistValue (PersistZonedTime x)) = do - put (13 :: Word8) - put (BinZT x) - put (BinPersistValue (PersistDbSpecific _)) = undefined put (BinPersistValue (PersistObjectId _)) = error "PersistObjectId is not supported." @@ -163,8 +162,8 @@ 10-> liftM (PersistList . map unBinPersistValue) (Q.get :: Get [BinPersistValue]) 11-> liftM (PersistMap . map (unBinText *** unBinPersistValue)) (Q.get :: Get [(BinText, BinPersistValue)]) 12-> liftM PersistRational (Q.get :: Get Rational) - 13-> liftM (PersistZonedTime . unBinZT) (Q.get :: Get BinZT) - _ -> fail "Incorrect tag came to Binary deserialization" +-- 13-> liftM (PersistZonedTime . unBinZT) (Q.get :: Get BinZT) + z -> fail ("Incorrect tag " ++ show z ++ " came to Binary deserialization") liftM BinPersistValue pv toValue :: PersistValue -> B.ByteString @@ -185,7 +184,7 @@ Left a -> fail (unpack a) -zipAndConvert :: PersistField t => [FieldDef a] -> [t] -> [(B.ByteString, B.ByteString)] +zipAndConvert :: PersistField t => [FieldDef] -> [t] -> [(B.ByteString, B.ByteString)] zipAndConvert [] _ = [] zipAndConvert _ [] = [] zipAndConvert (e:efields) (p:pfields) = @@ -221,3 +220,13 @@ -- | Construct an id key, that is incremented for access toKeyId :: PersistEntity val => val -> B.ByteString toKeyId val = B.append (toObjectPrefix val) idBs + +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 + Right z -> return z + Left a -> fail (unpack a) + where + q = keyFromValues [PersistText x] 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,27 @@ {-# LANGUAGE FlexibleContexts, UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.Redis.Store - ( RedisBackend - , execRedisT + ( execRedisT + , RedisBackend )where import Database.Persist -import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Trans.Control (MonadBaseControl) +import qualified Database.Persist.Sql as Sql import qualified Database.Redis as R -import Data.Text (Text) -import Database.Persist.Redis.Config (RedisT(..), thisConnection) +import qualified Data.ByteString as B +import Data.Text (Text, pack) +import Database.Persist.Redis.Config (RedisT, thisConnection) import Database.Persist.Redis.Internal +import Web.PathPieces (PathPiece (..)) -data RedisBackend +import Data.Aeson(FromJSON(..), ToJSON(..)) -toOid :: (PersistEntity val) => Text -> Key val -toOid = Key . PersistText +type RedisBackend = R.Connection -- | Fetches a next key from _id record createKey :: (R.RedisCtx m f, PersistEntity val) => val -> m (f Integer) @@ -42,46 +44,65 @@ (Right x) -> return x (Left x) -> fail x -instance (Applicative m, Functor m, MonadIO m, MonadBaseControl IO m) => PersistStore (RedisT m) where - type PersistMonadBackend (RedisT m) = RedisBackend +instance PersistStore R.Connection where + newtype BackendKey R.Connection = RedisKey Text + deriving (Show, Read, Eq, Ord, PersistField, FromJSON, ToJSON) insert val = do keyId <- execRedisT $ createKey val - let key = toOid $ toKeyText val keyId + let textKey = toKeyText val keyId + key <- toKey textKey _ <- insertKey key val return key - insertKey (Key (PersistText key)) val = do + insertKey k val = do let fields = toInsertFields val -- Inserts a hash map into _ record - _ <- execRedisT $ R.hmset (toB key) fields + _ <- execRedisT $ R.hmset (unKey k) fields return () - insertKey _ _ = fail "Wrong key type in insertKey" - repsert k@(Key (PersistText key)) val = do - _ <- execRedisT $ R.del [toB key] + repsert k val = do + _ <- execRedisT $ R.del [unKey k] insertKey k val return () - repsert _ _ = fail "Wrong key type in repsert" replace k val = do delete k insertKey k val return () - delete (Key (PersistText key)) = do - r <- execRedisT $ R.del [toB key] + delete k = do + r <- execRedisT $ R.del [unKey k] case r of 0 -> fail "there is no such key!" 1 -> return () _ -> fail "there are a lot of such keys!" - delete _ = fail "Wrong key type in delete" - get k@(Key (PersistText key)) = do - r <- execRedisT $ R.hgetall (toB key) + get k = do + r <- execRedisT $ R.hgetall (unKey k) if null r then return Nothing else do Entity _ val <- mkEntity k r return $ Just val - get _ = fail "Wrong key type in get" + + update _ [] = return () + update key upds = do + let fields = updatesToFields upds + _ <- execRedisT $ R.hmset (unKey key) fields + return () + +updatesToFields :: PersistEntity val => [Update val] -> [(B.ByteString, B.ByteString)] +updatesToFields = map updateToOneField + where + updateToOneField (Update field v up) = undefined + updateToOneField (BackendUpdate up) = undefined + +instance PathPiece (BackendKey RedisBackend) where + toPathPiece (RedisKey txt) = txt + fromPathPiece txt = Just $ RedisKey txt +-- some checking that entity exists and it is in format of entityname_id is omitted + +instance Sql.PersistFieldSql (BackendKey RedisBackend) where + sqlType _ = Sql.SqlOther (pack "doesn't make much sense for Redis backend") + 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: 0.2.2 +version: 0.3.0 license: BSD3 license-file: LICENSE author: Pavel Ryzhov @@ -10,6 +10,7 @@ cabal-version: >= 1.8 maintainer: Pavel Ryzhov build-type: Simple +bug-reports: https://github.com/yesodweb/persistent/issues source-repository head type: git @@ -19,17 +20,18 @@ build-depends: base >= 4 && < 5 , hedis >= 0.6.0 && < 0.7.0 , bytestring >= 0.10.0.0 && < 0.11.0.0 - , persistent >= 1.3 && < 1.4 - , text >= 0.8 - , aeson >= 0.5 + , persistent >= 2.1 && < 2.2 + , text >= 1.2.0.0 + , aeson >= 0.8 , time >= 1.4 && < 1.5 - , attoparsec - , mtl >= 2.1.2 && < 2.2.0 - , transformers >= 0.3.0.0 && < 0.4.0.0 - , monad-control >= 0.3.2.0 && < 0.3.3.0 + , attoparsec >= 0.12.0.0 + , mtl >= 2.2.0 && < 2.3 + , transformers >= 0.4.0.0 && < 0.5.0.0 + , monad-control >= 0.3.2.0 && < 0.4 , utf8-string >= 0.3.7 && < 0.4.0 , binary >= 0.7 && < 0.8 - , scientific + , scientific >= 0.3.1 && < 0.4 + , path-pieces >= 0.1 exposed-modules: Database.Persist.Redis @@ -44,18 +46,20 @@ main-is: tests/basic-test.hs build-depends: base >= 4 && < 5 , hedis >= 0.6.0 && < 0.7.0 - , persistent >= 1.3 && < 1.4 - , persistent-template >= 1.3 && < 1.4 - , mtl >= 2.1.2 && < 2.2.0 - , transformers >= 0.3.0.0 && < 0.4.0.0 + , persistent >= 2.1 && < 2.2 + , persistent-template >= 2.1 && < 2.2 + , mtl >= 2.2.0 && < 2.3 + , transformers >= 0.4.0.0 && < 0.5 , utf8-string >= 0.3.7 && < 0.4.0 , bytestring >= 0.10.0.0 && < 0.11.0.0 - , text >= 0.8 - , aeson >= 0.5 + , text >= 1.2.0.0 + , aeson >= 0.8 , binary >= 0.7 && < 0.8 , time >= 1.4 && < 1.5 - , attoparsec + , attoparsec >= 0.12.0.0 , template-haskell - , monad-control >= 0.3.2.0 && < 0.3.3.0 + , monad-control >= 0.3.2.0 && < 0.4 , utf8-string >= 0.3.7 && < 0.4.0 + , path-pieces >= 0.1 + , scientific , persistent-redis diff --git a/tests/basic-test.hs b/tests/basic-test.hs --- a/tests/basic-test.hs +++ b/tests/basic-test.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} {-# LANGUAGE TypeFamilies, EmptyDataDecls, GADTs #-} +{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} module Main where import qualified Database.Redis as R @@ -8,7 +9,7 @@ import Database.Persist.TH import Language.Haskell.TH.Syntax import Control.Monad.IO.Class (liftIO) -import Data.Text (Text, pack) +import Data.Text (Text, pack, unpack) let redisSettings = mkPersistSettings (ConT ''RedisBackend) in share [mkPersist redisSettings] [persistLowerCase| @@ -27,12 +28,18 @@ redisConf :: RedisConf redisConf = RedisConf host (R.connectPort d) Nothing 10 +mkKey :: (Monad m, PersistEntity val) => Text -> m (Key val) +mkKey s = case keyFromValues [PersistText s] of + Right z -> return z + Left a -> fail (unpack a) + main :: IO () main = withRedisConn redisConf $ runRedisPool $ do + liftIO $ print "Inserting..." s <- insert $ Person "Test" 12 - liftIO $ print s - let key = Key (PersistText "person_test") + liftIO $ ("Received the key" ++ (show s)) + key <- mkKey "person_test" insertKey key $ Person "Test2" 45 repsert s (Person "Test3" 55) g <- get key :: RedisT IO (Maybe Person)