persistent-redis 0.0.2 → 0.0.3
raw patch · 4 files changed
+107/−50 lines, 4 files
Files
- Database/Persist/Redis/Internal.hs +39/−15
- Database/Persist/Redis/Store.hs +43/−24
- persistent-redis.cabal +12/−3
- tests/basic-test.hs +13/−8
Database/Persist/Redis/Internal.hs view
@@ -1,35 +1,29 @@ {-# LANGUAGE OverloadedStrings #-} module Database.Persist.Redis.Internal ( toInsertFields- , toKey , toKeyId , toEntityName- , deconvert+ , toKeyText+ , toB+ , mkEntity ) where -import Data.Data import Data.Text (Text, unpack)+import qualified Data.Text as T import Database.Persist.Types import Database.Persist.Class-import Data.Aeson.Generic (encode) import qualified Data.ByteString as B-import Data.ByteString.Lazy (toStrict) import qualified Data.ByteString.UTF8 as U-import qualified Database.Redis as R -deconvert :: R.RedisCtx m f => f a -> a-deconvert = undefined- toLabel :: FieldDef a -> B.ByteString toLabel = U.fromString . unpack . unDBName . fieldDB +toEntityString :: PersistEntity val => val -> Text+toEntityString = unDBName . entityDB . entityDef . Just+ toEntityName :: EntityDef a -> B.ByteString toEntityName = U.fromString . unpack . unDBName . entityDB -moveToByteString :: Data a => Either Text a -> B.ByteString-moveToByteString (Left a) = U.fromString $ unpack a-moveToByteString (Right a) = toStrict $ encode a- toValue :: PersistValue -> B.ByteString toValue (PersistText x) = U.fromString $ unpack x toValue (PersistByteString x) = x@@ -42,8 +36,35 @@ toValue (PersistNull) = U.fromString "" toValue (PersistList x) = U.fromString $ show x toValue (PersistMap x) = U.fromString $ show x+toValue (PersistRational _) = undefined+toValue (PersistZonedTime _) = undefined toValue (PersistObjectId _) = error "PersistObjectId is not supported." +castOne :: SqlType -> String -> PersistValue+castOne SqlString x = PersistText (T.pack x) +castOne SqlInt32 x = PersistInt64 (read x)+castOne SqlInt64 x = PersistInt64 (read x)+castOne SqlBool x = PersistBool (read x)+castOne SqlReal x = PersistDouble (read x)+castOne _ _ = error "Unknown type"++redisToPerisistValues :: EntityDef SqlType -> [(B.ByteString, B.ByteString)] -> [PersistValue]+redisToPerisistValues entDef fields = recast fieldsAndValues+ where+ castColumns = map fieldSqlType (entityFields entDef)+ fieldsAndValues = zip castColumns (map (U.toString . snd) fields)+ recast :: [(SqlType, String)] -> [PersistValue]+ recast = map (uncurry castOne)++mkEntity :: (Monad m, PersistEntity val) => Key val -> EntityDef SqlType -> [(B.ByteString, B.ByteString)] -> m (Entity val)+mkEntity key entDef fields = do+ let values = redisToPerisistValues entDef fields+ let v = fromPersistValues values+ case v of+ Right body -> return $ Entity key body+ Left a -> fail (unpack a)++ zipAndConvert :: PersistField t => [FieldDef a] -> [t] -> [(B.ByteString, B.ByteString)] zipAndConvert [] _ = [] zipAndConvert _ [] = []@@ -64,8 +85,11 @@ underscoreBs = U.fromString "_" -- | Make a key for given entity and id-toKey :: PersistEntity val => val -> Integer -> B.ByteString-toKey val n = B.append (toObjectPrefix val) (U.fromString $ show n)+toKeyText :: PersistEntity val => val -> Integer -> Text+toKeyText val k = T.append (T.append (toEntityString val) "_") (T.pack $ show k)++toB :: Text -> B.ByteString+toB = U.fromString . unpack -- | Create a string key for given entity toObjectPrefix :: PersistEntity val => val -> B.ByteString
Database/Persist/Redis/Store.hs view
@@ -8,34 +8,27 @@ )where import Database.Persist-import Control.Applicative (Applicative, (<$>))+import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Monad.Reader.Class -import Control.Monad.Reader(ReaderT(..), runReaderT) import qualified Database.Redis as R-import Data.Text (pack)+import Data.Text (Text) import Database.Persist.Redis.Config (RedisT(..), thisConnection) import Database.Persist.Redis.Internal data RedisBackend -toOid :: (PersistEntity val) => Integer -> Key val-toOid = Key . PersistText . pack . show +dummyFromKey :: KeyBackend RedisBackend v -> v+dummyFromKey _ = error "dummyFromKey" +toOid :: (PersistEntity val) => Text -> Key val+toOid = Key . PersistText+ -- | Fetches a next key from <object>_id record createKey :: (R.RedisCtx m f, PersistEntity val) => val -> m (f Integer) createKey val = do let keyId = toKeyId val- oid <- R.incr keyId- return oid---- | Inserts a hash map into <object>_<id> record-insertImpl :: (R.RedisCtx m f, PersistEntity val) => val -> Integer -> m (f R.Status)-insertImpl val keyId = do- let fields = toInsertFields val- let key = toKey val keyId- R.hmset key fields+ R.incr keyId desugar :: R.TxResult a -> Either String a desugar (R.TxSuccess x) = Right x@@ -56,17 +49,43 @@ type PersistMonadBackend (RedisT m) = RedisBackend insert val = do- key <- execRedisT $ createKey val- r <- execRedisT $ insertImpl val key- liftIO $ print r- return $ toOid key+ keyId <- execRedisT $ createKey val+ let key = toOid $ toKeyText val keyId+ _ <- insertKey key val+ return key - insertKey k record = undefined+ insertKey (Key (PersistText key)) val = do+ let fields = toInsertFields val+ -- Inserts a hash map into <object>_<id> record+ _ <- execRedisT $ R.hmset (toB key) fields+ return ()+ insertKey _ _ = fail "Wrong key type in insertKey" - repsert k record = undefined+ repsert k@(Key (PersistText key)) val = do+ _ <- execRedisT $ R.del [toB key]+ insertKey k val+ return ()+ repsert _ _ = fail "Wrong key type in repsert" - replace k record = undefined+ replace k val = do+ delete k+ insertKey k val+ return () - delete k = undefined+ delete (Key (PersistText key)) = do+ r <- execRedisT $ R.del [toB key]+ 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 = undefined+ get k@(Key (PersistText key)) = do+ let t = entityDef $ Just $ dummyFromKey k+ r <- execRedisT $ R.hgetall (toB key)+ if null r+ then return Nothing+ else do+ Entity _ val <- mkEntity k t r+ return $ Just val+ get _ = fail "Wrong key type in get"
persistent-redis.cabal view
@@ -1,15 +1,25 @@ name: persistent-redis-version: 0.0.2+version: 0.0.3 license: BSD3 license-file: LICENSE author: Pavel Ryzhov <paul@paulrz.cz>-synopsis: Backend for the persistent library using Redis.+synopsis: Backend for Yesod persistent library using Redis. description: Based on the Redis package. category: Database, Yesod stability: Experimental cabal-version: >= 1.8+maintainer: Pavel Ryzhov <paul@paulrz.cz> build-type: Simple +source-repository head+ type: git+ location: https://github.com/paulrzcz/persistent-redis.git++source-repository this+ type: git+ location: https://github.com/paulrzcz/persistent-redis.git+ tag: 0.0.3+ library build-depends: base >= 4 && < 5 , hedis >= 0.6.0 && < 0.7.0@@ -28,7 +38,6 @@ other-modules: Database.Persist.Redis.Config Database.Persist.Redis.Internal Database.Persist.Redis.Store- ghc-options: -Wall
tests/basic-test.hs view
@@ -2,16 +2,15 @@ {-# LANGUAGE TypeFamilies, EmptyDataDecls, GADTs #-} module Main where -import Database.Redis+import qualified Database.Redis as R import Database.Persist import Database.Persist.Redis import Database.Persist.TH-import Database.Persist.Quasi import Language.Haskell.TH.Syntax import Control.Monad.IO.Class (liftIO) import Data.Text (Text, pack) -let redisSettings = (mkPersistSettings (ConT ''RedisBackend))+let redisSettings = mkPersistSettings (ConT ''RedisBackend) in share [mkPersist redisSettings] [persistLowerCase| Person name String@@ -19,18 +18,24 @@ deriving Show |] -d :: ConnectInfo-d = defaultConnectInfo+d :: R.ConnectInfo+d = R.defaultConnectInfo host :: Text-host = pack $ connectHost d+host = pack $ R.connectHost d redisConf :: RedisConf-redisConf = RedisConf host (connectPort d) Nothing 10+redisConf = RedisConf host (R.connectPort d) Nothing 10 main :: IO ()-main = do+main = withRedisConn redisConf $ runRedisPool $ do s <- insert $ Person "Test" 12 liftIO $ print s+ let key = Key (PersistText "person_test")+ insertKey key $ Person "Test2" 45+ repsert s (Person "Test3" 55)+ g <- get key :: RedisT IO (Maybe Person)+ liftIO $ print g+ delete s return ()