diff --git a/Database/Persist/Redis.hs b/Database/Persist/Redis.hs --- a/Database/Persist/Redis.hs +++ b/Database/Persist/Redis.hs @@ -1,7 +1,9 @@ module Database.Persist.Redis ( module Database.Persist.Redis.Config , module Database.Persist.Redis.Store + , module Database.Persist.Redis.Exception ) where import Database.Persist.Redis.Config import Database.Persist.Redis.Store +import Database.Persist.Redis.Exception diff --git a/Database/Persist/Redis/Exception.hs b/Database/Persist/Redis/Exception.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Redis/Exception.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Database.Persist.Redis.Exception + ( RedisException (..) + ) where + +import Data.Typeable (Typeable) +import Control.Exception (Exception) + +data RedisException = NotSupportedOperation String + | ParserError String + | 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 + show (NotSupportedValueType tp) = "The value type " ++ tp ++ " is not supported for Redis" + show IncorrectBehavior = "The behavior of persistent-redis is incorrect" + show (IncorrectUpdate msg) = "This update is not possible: " ++ msg +instance Exception RedisException 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,31 +1,23 @@ {-# LANGUAGE OverloadedStrings #-} module Database.Persist.Redis.Internal - ( toInsertFields + ( toKey + , unKey + , mkEntity , toKeyId - , toEntityName , toKeyText + , toInsertFields , toB - , mkEntity - , unKey - , toKey ) where -import Control.Arrow((***)) -import Data.Fixed -import Data.Time -import Data.Int (Int64) -import Data.Word (Word8) -import Control.Monad (liftM, liftM3) -import Data.Binary (Binary(..), encode, getWord8, Get) -import qualified Data.Binary as Q 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.Lazy as L import qualified Data.ByteString.UTF8 as U +import Database.Persist.Redis.Parser + toLabel :: FieldDef -> B.ByteString toLabel = U.fromString . unpack . unDBName . fieldDB @@ -34,146 +26,6 @@ toEntityName :: EntityDef -> B.ByteString toEntityName = U.fromString . unpack . unDBName . entityDB - -newtype BinText = BinText { unBinText :: Text } -instance Binary BinText where - put = put . U.fromString . unpack . unBinText - get = do - str <- Q.get - return $ BinText $ (T.pack . U.toString) str - -newtype BinPico= BinPico { unBinPico :: Pico } -instance Binary BinPico where - put = put . toRational . unBinPico - get = do - x <- Q.get :: Get Rational - return $ BinPico (fromRational x) - -newtype BinDiffTime = BinDiffTime { unBinDiffTime :: DiffTime } -instance Binary BinDiffTime where - put = put . toRational . unBinDiffTime - get = do - x <- Q.get :: Get Rational - return $ BinDiffTime (fromRational x) - -newtype BinDay = BinDay { unBinDay :: Day } -instance Binary BinDay where - put (BinDay (ModifiedJulianDay x)) = put x - get = do - x <- Q.get :: Get Integer - return $ BinDay (ModifiedJulianDay x) - -newtype BinTimeOfDay = BinTimeOfDay { unBinTimeOfDay :: TimeOfDay } -instance Binary BinTimeOfDay where - put (BinTimeOfDay (TimeOfDay h m s)) = do - put h - put m - put (BinPico s) - get = do - let s = liftM unBinPico (Q.get :: Get BinPico) - 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 - put (BinDay day) - put (BinTimeOfDay timeOfDay) - put mins - put summer - put name - - get = do - day <- Q.get :: Get BinDay - timeOfDay <- Q.get :: Get BinTimeOfDay - mins <- Q.get :: Get Int - 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 - put (1 :: Word8) - put $ (U.fromString . unpack) x - - put (BinPersistValue (PersistByteString x)) = do - put (2 :: Word8) - put x - - put (BinPersistValue (PersistInt64 x)) = do - put (3 :: Word8) - put x - - put (BinPersistValue (PersistDouble x)) = do - put (4 :: Word8) - put x - - put (BinPersistValue (PersistBool x)) = do - put (5 :: Word8) - put x - - put (BinPersistValue (PersistDay day)) = do - put (6 :: Word8) - put (BinDay day) - - put (BinPersistValue (PersistTimeOfDay tod)) = do - put (7 :: Word8) - put (BinTimeOfDay tod) - - put (BinPersistValue (PersistUTCTime (UTCTime day pc))) = do - put (8 :: Word8) - put (BinDay day) - put (BinDiffTime pc) - - put (BinPersistValue PersistNull) = put (9 :: Word8) - put (BinPersistValue (PersistList x)) = do - put (10 :: Word8) - put (map BinPersistValue x) - - put (BinPersistValue (PersistMap x)) = do - put (11 :: Word8) - put (map (BinText *** BinPersistValue) x) - - put (BinPersistValue (PersistRational x)) = do - put (12 :: Word8) - put x - - put (BinPersistValue (PersistDbSpecific _)) = undefined - put (BinPersistValue (PersistObjectId _)) = error "PersistObjectId is not supported." - - get = do - tag <- getWord8 - let pv = case tag of - 1 -> liftM (PersistText . unBinText) (Q.get :: Get BinText) - 2 -> liftM PersistByteString (Q.get :: Get B.ByteString) - 3 -> liftM PersistInt64 (Q.get :: Get Int64) - 4 -> liftM PersistDouble (Q.get :: Get Double) - 5 -> liftM PersistBool (Q.get :: Get Bool) - 6 -> liftM (PersistDay . unBinDay) (Q.get :: Get BinDay) - 7 -> liftM (PersistTimeOfDay . unBinTimeOfDay) (Q.get :: Get BinTimeOfDay) - 8 -> do - d <- Q.get :: Get BinDay - dt <- Q.get :: Get BinDiffTime - let utctime = UTCTime (unBinDay d) (unBinDiffTime dt) - return $ PersistUTCTime utctime - 9 -> return PersistNull - 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) - z -> fail ("Incorrect tag " ++ show z ++ " came to Binary deserialization") - liftM BinPersistValue pv - -toValue :: PersistValue -> B.ByteString -toValue = L.toStrict . encode . BinPersistValue - -castOne :: B.ByteString -> PersistValue -castOne = unBinPersistValue . Q.decode . L.fromStrict - -redisToPerisistValues :: [(B.ByteString, B.ByteString)] -> [PersistValue] -redisToPerisistValues = map (castOne . snd) mkEntity :: (Monad m, PersistEntity val) => Key val -> [(B.ByteString, B.ByteString)] -> m (Entity val) mkEntity key fields = do diff --git a/Database/Persist/Redis/Parser.hs b/Database/Persist/Redis/Parser.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Redis/Parser.hs @@ -0,0 +1,162 @@ +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 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 Database.Persist.Types +import Database.Persist.Redis.Exception + +newtype BinText = BinText { unBinText :: Text } +instance Binary BinText where + put = put . U.fromString . unpack . unBinText + get = do + str <- Q.get + return $ BinText $ (T.pack . U.toString) str + +newtype BinPico= BinPico { unBinPico :: Pico } +instance Binary BinPico where + put = put . toRational . unBinPico + get = do + x <- Q.get :: Get Rational + return $ BinPico (fromRational x) + +newtype BinDiffTime = BinDiffTime { unBinDiffTime :: DiffTime } +instance Binary BinDiffTime where + put = put . toRational . unBinDiffTime + get = do + x <- Q.get :: Get Rational + return $ BinDiffTime (fromRational x) + +newtype BinDay = BinDay { unBinDay :: Day } +instance Binary BinDay where + put (BinDay (ModifiedJulianDay x)) = put x + get = do + x <- Q.get :: Get Integer + return $ BinDay (ModifiedJulianDay x) + +newtype BinTimeOfDay = BinTimeOfDay { unBinTimeOfDay :: TimeOfDay } +instance Binary BinTimeOfDay where + put (BinTimeOfDay (TimeOfDay h m s)) = do + put h + put m + put (BinPico s) + get = do + let s = liftM unBinPico (Q.get :: Get BinPico) + 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 + put (BinDay day) + put (BinTimeOfDay timeOfDay) + put mins + put summer + put name + + get = do + day <- Q.get :: Get BinDay + timeOfDay <- Q.get :: Get BinTimeOfDay + mins <- Q.get :: Get Int + 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 + put (1 :: Word8) + put $ (U.fromString . unpack) x + + put (BinPersistValue (PersistByteString x)) = do + put (2 :: Word8) + put x + + put (BinPersistValue (PersistInt64 x)) = do + put (3 :: Word8) + put x + + put (BinPersistValue (PersistDouble x)) = do + put (4 :: Word8) + put x + + put (BinPersistValue (PersistBool x)) = do + put (5 :: Word8) + put x + + put (BinPersistValue (PersistDay day)) = do + put (6 :: Word8) + put (BinDay day) + + put (BinPersistValue (PersistTimeOfDay tod)) = do + put (7 :: Word8) + put (BinTimeOfDay tod) + + put (BinPersistValue (PersistUTCTime (UTCTime day pc))) = do + put (8 :: Word8) + put (BinDay day) + put (BinDiffTime pc) + + put (BinPersistValue PersistNull) = put (9 :: Word8) + put (BinPersistValue (PersistList x)) = do + put (10 :: Word8) + put (map BinPersistValue x) + + put (BinPersistValue (PersistMap x)) = do + put (11 :: Word8) + put (map (BinText *** BinPersistValue) x) + + put (BinPersistValue (PersistRational x)) = do + put (12 :: Word8) + put x + + put (BinPersistValue (PersistDbSpecific _)) = throw $ NotSupportedValueType "PersistDbSpecific" + put (BinPersistValue (PersistObjectId _)) = throw $ NotSupportedValueType "PersistObjectId" + + get = do + tag <- getWord8 + let pv = case tag of + 1 -> liftM (PersistText . unBinText) (Q.get :: Get BinText) + 2 -> liftM PersistByteString (Q.get :: Get B.ByteString) + 3 -> liftM PersistInt64 (Q.get :: Get Int64) + 4 -> liftM PersistDouble (Q.get :: Get Double) + 5 -> liftM PersistBool (Q.get :: Get Bool) + 6 -> liftM (PersistDay . unBinDay) (Q.get :: Get BinDay) + 7 -> liftM (PersistTimeOfDay . unBinTimeOfDay) (Q.get :: Get BinTimeOfDay) + 8 -> do + d <- Q.get :: Get BinDay + dt <- Q.get :: Get BinDiffTime + let utctime = UTCTime (unBinDay d) (unBinDiffTime dt) + return $ PersistUTCTime utctime + 9 -> return PersistNull + 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) + z -> throw $ ParserError ("Incorrect tag " ++ show z ++ " came to Binary deserialization") + liftM BinPersistValue pv + +toValue :: PersistValue -> B.ByteString +toValue = L.toStrict . encode . BinPersistValue + +castOne :: B.ByteString -> PersistValue +castOne = unBinPersistValue . Q.decode . L.fromStrict + +redisToPerisistValues :: [(B.ByteString, B.ByteString)] -> [PersistValue] +redisToPerisistValues = map (castOne . snd) 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 @@ -13,10 +13,10 @@ import Control.Monad.IO.Class (MonadIO (..)) import qualified Database.Persist.Sql as Sql import qualified Database.Redis as R -import qualified Data.ByteString as B import Data.Text (Text, pack) import Database.Persist.Redis.Config (RedisT, thisConnection) import Database.Persist.Redis.Internal +import Database.Persist.Redis.Update import Web.PathPieces (PathPiece (..)) import Data.Aeson(FromJSON(..), ToJSON(..)) @@ -86,17 +86,16 @@ Entity _ val <- mkEntity k r return $ Just val - 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 + update _ [] = return () + update k upds = do + r <- execRedisT $ R.hgetall (unKey k) + if null r + then fail "No such key exists!" + else do + v <- mkEntity k r + let (Entity _ val) = cmdUpdate v upds + insertKey k val + return() instance PathPiece (BackendKey RedisBackend) where toPathPiece (RedisKey txt) = txt diff --git a/Database/Persist/Redis/Update.hs b/Database/Persist/Redis/Update.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Redis/Update.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE RankNTypes #-} +module Database.Persist.Redis.Update + ( cmdUpdate + ) where + +import Control.Exception (throw) +import Data.Functor.Identity +import Data.Functor.Constant +import Data.Either () + +import Database.Persist +import Database.Persist.Redis.Exception + +type ASetter s t a b = (a -> Identity b) -> s -> Identity t + +set :: ASetter s t a b -> b -> s -> t +set l b = runIdentity . l (\_ -> Identity b) + +type Getting r s t a b = (a -> Constant r b) -> s -> Constant r t + +view :: s -> Getting a s t a b -> a +view s l = getConstant (l Constant s) + +cmdUpdate :: PersistEntity val => Entity val -> [Update val] -> Entity val +cmdUpdate = foldr updateOneField + +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 _)) _ = + throw $ NotSupportedOperation "Backend specific update withing update operation" + +updateOneField (Update field v up) oldValue = set (fieldLens field) newValue oldValue + where + lens = fieldLens field + pv = toPersistValue v + oldV = toPersistValue $ view oldValue lens + eitherNewValue = fromPersistValue $ apply up oldV pv + newValue = either (\_ -> throw IncorrectBehavior) id eitherNewValue + + +apply :: PersistUpdate -> PersistValue -> PersistValue -> PersistValue + +apply Assign _ _ = throw IncorrectBehavior + +apply Add (PersistInt64 x) (PersistInt64 y) = PersistInt64 (x + y) +apply Add (PersistDouble x) (PersistDouble y) = PersistDouble (x + y) +apply Add (PersistRational x) (PersistRational y) = PersistRational (x + y) +apply Add _ _ = throw $ IncorrectUpdate "Unable to apply addition to this field" + +apply Subtract (PersistInt64 x) (PersistInt64 y) = PersistInt64 (x - y) +apply Subtract (PersistDouble x) (PersistDouble y) = PersistDouble (x - y) +apply Subtract (PersistRational x) (PersistRational y) = PersistRational (x - y) +apply Subtract _ _ = throw $ IncorrectUpdate "Unable to apply subtraction to this field" + +apply Multiply (PersistInt64 x) (PersistInt64 y) = PersistInt64 (x * y) +apply Multiply (PersistDouble x) (PersistDouble y) = PersistDouble (x * y) +apply Multiply (PersistRational x) (PersistRational y) = PersistRational (x * y) +apply Multiply _ _ = throw $ IncorrectUpdate "Unable to apply subtraction to this field" + +apply Divide (PersistInt64 x) (PersistInt64 y) = PersistInt64 (div x y) +apply Divide (PersistDouble x) (PersistDouble y) = PersistDouble (x / y) +apply Divide (PersistRational x) (PersistRational y) = PersistRational (x / y) +apply Divide _ _ = throw $ IncorrectUpdate "Unable to apply subtraction to this field" + +apply (BackendSpecificUpdate _) _ _ = throw IncorrectBehavior 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.3.0 +version: 0.3.1 license: BSD3 license-file: LICENSE author: Pavel Ryzhov @@ -38,6 +38,9 @@ other-modules: Database.Persist.Redis.Config Database.Persist.Redis.Internal Database.Persist.Redis.Store + Database.Persist.Redis.Parser + Database.Persist.Redis.Update + Database.Persist.Redis.Exception ghc-options: -Wall diff --git a/tests/basic-test.hs b/tests/basic-test.hs --- a/tests/basic-test.hs +++ b/tests/basic-test.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} {-# LANGUAGE TypeFamilies, EmptyDataDecls, GADTs #-} {-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} module Main where @@ -36,10 +36,10 @@ main :: IO () main = withRedisConn redisConf $ runRedisPool $ do - liftIO $ print "Inserting..." + _ <- liftIO $ print "Inserting..." s <- insert $ Person "Test" 12 - liftIO $ ("Received the key" ++ (show s)) - key <- mkKey "person_test" + _ <- liftIO $ print ("Received the key" ++ show s) + key <- mkKey (pack "person_test") insertKey key $ Person "Test2" 45 repsert s (Person "Test3" 55) g <- get key :: RedisT IO (Maybe Person)