packages feed

persistent-redis 0.3.0 → 0.3.1

raw patch · 8 files changed

+276/−171 lines, 8 files

Files

Database/Persist/Redis.hs view
@@ -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
+ Database/Persist/Redis/Exception.hs view
@@ -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
Database/Persist/Redis/Internal.hs view
@@ -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
+ Database/Persist/Redis/Parser.hs view
@@ -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)
Database/Persist/Redis/Store.hs view
@@ -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
+ Database/Persist/Redis/Update.hs view
@@ -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
persistent-redis.cabal view
@@ -1,5 +1,5 @@ name:            persistent-redis-version:         0.3.0+version:         0.3.1 license:         BSD3 license-file:    LICENSE author:          Pavel Ryzhov <paul@paulrz.cz>@@ -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
tests/basic-test.hs view
@@ -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)