persistent-redis 0.2.2 → 0.3.0
raw patch · 5 files changed
+102/−62 lines, 5 filesdep +path-piecesdep ~aesondep ~attoparsecdep ~monad-control
Dependencies added: path-pieces
Dependency ranges changed: aeson, attoparsec, monad-control, mtl, persistent, persistent-template, scientific, text, transformers
Files
- Database/Persist/Redis/Config.hs +6/−7
- Database/Persist/Redis/Internal.hs +19/−10
- Database/Persist/Redis/Store.hs +46/−25
- persistent-redis.cabal +21/−17
- tests/basic-test.hs +10/−3
Database/Persist/Redis/Config.hs view
@@ -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
Database/Persist/Redis/Internal.hs view
@@ -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]
Database/Persist/Redis/Store.hs view
@@ -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 <object>_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 <object>_<id> 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")+
persistent-redis.cabal view
@@ -1,5 +1,5 @@ name: persistent-redis-version: 0.2.2+version: 0.3.0 license: BSD3 license-file: LICENSE author: Pavel Ryzhov <paul@paulrz.cz>@@ -10,6 +10,7 @@ cabal-version: >= 1.8 maintainer: Pavel Ryzhov <paul@paulrz.cz> 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
tests/basic-test.hs view
@@ -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)