diff --git a/.travis.yml b/.travis.yml index 787c3a69c..97728033b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,9 @@ language: haskell install: + - sudo add-apt-repository -y ppa:yandex-sysmon/zookeeper-3.4 + - sudo apt-get update + - sudo apt-get install libzookeeper-mt-dev zookeeperd - cabal update - cabal install -j hspec cabal-meta cabal-src - cabal-meta install -j --only-dep --force-reinstalls @@ -13,12 +16,20 @@ script: - "cabal configure -fmysql --enable-tests && cabal test" - "cabal configure -fpostgresql --enable-tests && cabal test" - "cabal configure -fmongodb --enable-tests && cabal test" + - "cabal configure -fzookeeper --enable-tests && cabal test" addons: postgresql: "9.3" before_script: - psql -c 'create database persistent;' -U postgres - mysql -e 'create database persistent;' + - sudo mkdir -p /var/log/zookeeper + - sudo chmod -R 777 /var/log/zookeeper + - sudo chmod 666 /etc/zookeeper/conf/zoo.cfg + - echo maxClientCnxns=128 >> /etc/zookeeper/conf/zoo.cfg + - sudo service zookeeper restart + - sleep 10 + - /usr/share/zookeeper/bin/zkCli.sh create /persistent null services: - mysql diff --git a/package-list.sh b/package-list.sh index 25ce62f35..90b1df739 100644 --- a/package-list.sh +++ b/package-list.sh @@ -7,5 +7,6 @@ pkgs=( ./pool-conduit ./persistent-postgresql ./persistent-mysql ./persistent-mongoDB + ./persistent-zookeeper ) diff --git a/persistent-test/CompositeTest.hs b/persistent-test/CompositeTest.hs index 73fb848af..b3829b9be 100644 --- a/persistent-test/CompositeTest.hs +++ b/persistent-test/CompositeTest.hs @@ -38,14 +38,14 @@ import qualified Control.Exception.Control as Control import Init import Control.Applicative ((<$>),(<*>)) -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL import Data.Maybe (isJust) import Database.Persist.TH (mkDeleteCascade) #endif -- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs -#if WITH_MONGODB +#if WITH_NOSQL mkPersist persistSettings { mpsGeneric = False } [persistUpperCase| #else share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "compositeMigrate", mkDeleteCascade persistSettings { mpsGeneric = False }] [persistLowerCase| @@ -87,7 +87,7 @@ share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "compositeMig |] -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL cleanDB :: (PersistQuery backend, PersistEntityBackend TestChild ~ backend, MonadIO m) => ReaderT backend m () cleanDB = do deleteWhere ([] :: [Filter TestChild]) diff --git a/persistent-test/DataTypeTest.hs b/persistent-test/DataTypeTest.hs index f9cfcb761..7a450e684 100644 --- a/persistent-test/DataTypeTest.hs +++ b/persistent-test/DataTypeTest.hs @@ -23,7 +23,7 @@ import Init type Tuple a b = (a, b) -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL mkPersist persistSettings [persistUpperCase| #else -- Test lower case names @@ -40,7 +40,7 @@ DataTypeTable no-json double Double bool Bool day Day -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL pico Pico time TimeOfDay #endif @@ -53,7 +53,7 @@ cleanDB = deleteWhere ([] :: [Filter DataTypeTable]) specs :: Spec specs = describe "data type specs" $ it "handles all types" $ asIO $ runConn $ do -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL _ <- runMigrationSilent dataTypeMigrate -- Ensure reading the data from the database works... _ <- runMigrationSilent dataTypeMigrate @@ -80,11 +80,11 @@ specs = describe "data type specs" $ check "intList" dataTypeTableIntList check "bool" dataTypeTableBool check "day" dataTypeTableDay -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL check' "pico" dataTypeTablePico check "time" (roundTime . dataTypeTableTime) #endif -#if !(defined(WITH_MONGODB)) || (defined(WITH_MONGODB) && defined(HIGH_PRECISION_DATE)) +#if !(defined(WITH_NOSQL)) || (defined(WITH_NOSQL) && defined(HIGH_PRECISION_DATE)) check "utc" (roundUTCTime . dataTypeTableUtc) #endif @@ -129,7 +129,7 @@ instance Arbitrary DataTypeTable where <*> arbitrary -- double <*> arbitrary -- bool <*> arbitrary -- day -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL <*> arbitrary -- pico <*> (truncateTimeOfDay =<< arbitrary) -- time #endif diff --git a/persistent-test/EmbedOrderTest.hs b/persistent-test/EmbedOrderTest.hs index 103da773a..c0228b6e9 100644 --- a/persistent-test/EmbedOrderTest.hs +++ b/persistent-test/EmbedOrderTest.hs @@ -3,7 +3,7 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell, OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls, MultiParamTypeClasses #-} module EmbedOrderTest (specs, -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL embedOrderMigrate #endif ) where @@ -15,7 +15,7 @@ import Debug.Trace (trace) debug :: Show s => s -> s debug x = trace (show x) x -#if WITH_MONGODB +#if WITH_NOSQL mkPersist persistSettings [persistUpperCase| #else share [mkPersist sqlSettings, mkMigrate "embedOrderMigrate"] [persistUpperCase| @@ -30,7 +30,7 @@ Bar deriving Eq Show |] -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL cleanDB :: (PersistQuery backend, PersistEntityBackend Foo ~ backend, MonadIO m) => ReaderT backend m () cleanDB = do deleteWhere ([] :: [Filter Foo]) diff --git a/persistent-test/EmbedTest.hs b/persistent-test/EmbedTest.hs index 803528364..3b9ab5fed 100644 --- a/persistent-test/EmbedTest.hs +++ b/persistent-test/EmbedTest.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} module EmbedTest (specs, -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL embedMigrate #endif ) where @@ -14,10 +14,12 @@ import Data.Typeable (Typeable) import qualified Data.Text as T import qualified Data.Set as S import qualified Data.Map as M -#if WITH_MONGODB +#if WITH_NOSQL +#ifdef WITH_MONGODB import Database.Persist.MongoDB import Database.MongoDB (genObjectId) import Database.MongoDB (Value(String)) +#endif import EntityEmbedTest import System.Process (readProcess) #endif @@ -38,8 +40,9 @@ instance PersistField a => PersistField (NonEmpty a) where Right (l:ls) -> Right (l:|ls) -#if WITH_MONGODB +#if WITH_NOSQL mkPersist persistSettings [persistUpperCase| +#ifdef WITH_MONGODB HasObjectId oid ObjectId name Text @@ -54,6 +57,7 @@ mkPersist persistSettings [persistUpperCase| hasEntity (Entity ARecord) arrayWithEntities [AnEntity] deriving Show Eq Read Ord +#endif #else share [mkPersist sqlSettings, mkMigrate "embedMigrate"] [persistUpperCase| @@ -141,7 +145,7 @@ share [mkPersist sqlSettings, mkMigrate "embedMigrate"] [persistUpperCase| ints [Int] deriving Show Eq |] -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL cleanDB :: (PersistQuery backend, PersistEntityBackend HasMap ~ backend, MonadIO m) => ReaderT backend m () cleanDB = do deleteWhere ([] :: [Filter HasEmbed]) @@ -266,6 +270,7 @@ specs = describe "embedded entities" $ do Just res <- selectFirst [EmbedsHasMapName ==. (Just "empty map")] [] res @== Entity contK container +#ifdef WITH_NOSQL #ifdef WITH_MONGODB it "List" $ db $ do k1 <- insert $ HasList [] @@ -409,3 +414,4 @@ specs = describe "embedded entities" $ do lists <- selectList [] [] fmap entityVal lists @== [ListEmbed [InList 1 2, InList 1 2] 1 2] #endif +#endif diff --git a/persistent-test/EmptyEntityTest.hs b/persistent-test/EmptyEntityTest.hs index ffc0db036..9591dfa14 100644 --- a/persistent-test/EmptyEntityTest.hs +++ b/persistent-test/EmptyEntityTest.hs @@ -9,7 +9,7 @@ import Control.Monad.Trans.Resource (runResourceT) import Init -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL mkPersist persistSettings [persistUpperCase| #else -- Test lower case names @@ -18,15 +18,15 @@ share [mkPersist sqlSettings, mkMigrate "dataTypeMigrate"] [persistLowerCase| EmptyEntity |] -#ifdef WITH_MONGODB -cleanDB :: MonadIO m => ReaderT MongoContext m () +#ifdef WITH_NOSQL +cleanDB :: MonadIO m => ReaderT Context m () cleanDB = deleteWhere ([] :: [Filter EmptyEntity]) #endif specs :: Spec specs = describe "empty entity" $ it "inserts" $ (id :: IO () -> IO ()) $ runResourceT $ runConn $ do -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL _ <- runMigrationSilent dataTypeMigrate -- Ensure reading the data from the database works... _ <- runMigrationSilent dataTypeMigrate diff --git a/persistent-test/EntityEmbedTest.hs b/persistent-test/EntityEmbedTest.hs index 2d34b9ff6..0ae1c7611 100644 --- a/persistent-test/EntityEmbedTest.hs +++ b/persistent-test/EntityEmbedTest.hs @@ -5,7 +5,7 @@ module EntityEmbedTest where -- because we are using a type alias we need to declare in a separate module -- this is used in EmbedTest -#if WITH_MONGODB +#if WITH_NOSQL import Init mkPersist persistSettings [persistUpperCase| diff --git a/persistent-test/HtmlTest.hs b/persistent-test/HtmlTest.hs index af5e04a62..72fe0a599 100644 --- a/persistent-test/HtmlTest.hs +++ b/persistent-test/HtmlTest.hs @@ -27,7 +27,7 @@ cleanDB = do specs :: Spec specs = describe "html" $ do it "works" $ asIO $ runResourceT $ runConn $ do -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL _ <- runMigrationSilent htmlMigrate -- Ensure reading the data from the database works... _ <- runMigrationSilent htmlMigrate diff --git a/persistent-test/Init.hs b/persistent-test/Init.hs index 065017524..b99999c4a 100644 --- a/persistent-test/Init.hs +++ b/persistent-test/Init.hs @@ -16,13 +16,13 @@ module Init ( , MonadIO , persistSettings , MkPersistSettings (..) -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL , dbName , db' - , setupMongo + , setup , mkPersistSettings , Action - , MongoDB.MongoContext + , Context #else , db , sqlite_database @@ -40,7 +40,7 @@ module Init ( , Text , module Control.Monad.Trans.Reader , module Control.Monad -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL , module Database.Persist.Sql #endif ) where @@ -59,15 +59,26 @@ import Database.Persist.TH () import Data.Text (Text, unpack) import System.Environment (getEnvironment) -#ifdef WITH_MONGODB -import qualified Database.MongoDB as MongoDB -import Database.Persist.MongoDB (Action, withMongoPool, runMongoDBPool, defaultMongoConf, applyDockerEnv, BackendKey(..)) +#ifdef WITH_NOSQL import Language.Haskell.TH.Syntax (Type(..)) import Database.Persist.TH (mkPersistSettings) import qualified Data.ByteString as BS import Control.Monad (void, replicateM, liftM) +# ifdef WITH_MONGODB +import qualified Database.MongoDB as MongoDB +import Database.Persist.MongoDB (Action, withMongoPool, runMongoDBPool, defaultMongoConf, applyDockerEnv, BackendKey(..)) +# endif + +# ifdef WITH_ZOOKEEPER +import qualified Database.Zookeeper as Z +import Database.Persist.Zookeeper (Action, withZookeeperPool, runZookeeperPool, ZookeeperConf(..), defaultZookeeperConf, BackendKey(..), deleteRecursive) +import Data.IORef (newIORef, IORef, writeIORef, readIORef) +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.Text as T +# endif + #else import Control.Monad (liftM) import Database.Persist.Sql @@ -96,6 +107,22 @@ import Data.Int (Int32, Int64) import Control.Monad.IO.Class + +#ifdef WITH_MONGODB +setup :: Action IO () +setup = setupMongo +type Context = MongoDB.MongoContext +#endif + +#ifdef WITH_ZOOKEEPER +setup :: Action IO () +setup = setupZookeeper +type Context = Z.Zookeeper +#endif + + + + (@/=), (@==), (==@) :: (Eq a, Show a, MonadIO m) => a -> a -> m () infix 1 @/= --, /=@ actual @/= expected = liftIO $ assertNotEqual "" expected actual @@ -128,14 +155,16 @@ isTravis = do Just "true" -> True _ -> False -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL persistSettings :: MkPersistSettings -persistSettings = (mkPersistSettings $ ConT ''MongoDB.MongoContext) { mpsGeneric = True } +persistSettings = (mkPersistSettings $ ConT ''Context) { mpsGeneric = True } dbName :: Text dbName = "persistent" -type BackendMonad = MongoDB.MongoContext +type BackendMonad = Context + +#ifdef WITH_MONGODB runConn :: (MonadIO m, MonadBaseControl IO m) => Action m backend -> m () runConn f = do conf <- liftIO $ applyDockerEnv $ defaultMongoConf dbName -- { mgRsPrimary = Just "replicaset" } @@ -143,7 +172,19 @@ runConn f = do setupMongo :: Action IO () setupMongo = void $ MongoDB.dropDatabase dbName +#endif +#ifdef WITH_ZOOKEEPER +runConn :: (MonadIO m, MonadBaseControl IO m) => Action m backend -> m () +runConn f = do + let conf = defaultZookeeperConf {zCoord = "localhost:2181/" ++ T.unpack dbName} + void $ withZookeeperPool conf $ runZookeeperPool f + +setupZookeeper :: Action IO () +setupZookeeper = do + liftIO $ Z.setDebugLevel Z.ZLogError + deleteRecursive "/" +#endif db' :: Action IO () -> Action IO () -> Assertion db' actions cleanDB = do @@ -152,7 +193,6 @@ db' actions cleanDB = do instance Arbitrary PersistValue where arbitrary = PersistObjectId `fmap` BS.pack `fmap` replicateM 12 arbitrary - #else persistSettings :: MkPersistSettings persistSettings = sqlSettings { mpsGeneric = True } @@ -214,6 +254,7 @@ instance Random Int64 where instance Arbitrary PersistValue where arbitrary = PersistInt64 `fmap` choose (0, maxBound) + #endif instance PersistStore backend => Arbitrary (BackendKey backend) where @@ -223,9 +264,24 @@ instance PersistStore backend => Arbitrary (BackendKey backend) where Left e -> error $ unpack e Right r -> r +#ifdef WITH_NOSQL #ifdef WITH_MONGODB -generateKey :: IO (BackendKey MongoDB.MongoContext) +generateKey :: IO (BackendKey Context) generateKey = MongoKey `liftM` MongoDB.genObjectId +#endif + +#ifdef WITH_ZOOKEEPER +keyCounter :: IORef Int64 +keyCounter = unsafePerformIO $ newIORef 1 +{-# NOINLINE keyCounter #-} + +generateKey :: IO (BackendKey Context) +generateKey = do + i <- readIORef keyCounter + writeIORef keyCounter (i + 1) + return $ ZooKey $ T.pack $ show i +#endif + #else keyCounter :: IORef Int64 keyCounter = unsafePerformIO $ newIORef 1 diff --git a/persistent-test/LargeNumberTest.hs b/persistent-test/LargeNumberTest.hs index db7adfb08..5804b5f60 100644 --- a/persistent-test/LargeNumberTest.hs +++ b/persistent-test/LargeNumberTest.hs @@ -4,7 +4,7 @@ module LargeNumberTest where import Init import Data.Word -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL mkPersist persistSettings [persistUpperCase| #else share [mkPersist sqlSettings, mkMigrate "numberMigrate"] [persistLowerCase| @@ -18,7 +18,7 @@ share [mkPersist sqlSettings, mkMigrate "numberMigrate"] [persistLowerCase| deriving Show Eq |] -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Number ~ backend) => ReaderT backend m () cleanDB = do deleteWhere ([] :: [Filter Number]) diff --git a/persistent-test/MaxLenTest.hs b/persistent-test/MaxLenTest.hs index dbc2d0dd3..822e7829a 100644 --- a/persistent-test/MaxLenTest.hs +++ b/persistent-test/MaxLenTest.hs @@ -3,7 +3,7 @@ module MaxLenTest ( specs -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL , maxlenMigrate #endif ) where @@ -12,7 +12,7 @@ import Init import Data.String (IsString) import Data.ByteString (ByteString) -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL db :: Action IO () -> Assertion db = db' (return ()) mkPersist persistSettings [persistUpperCase| diff --git a/persistent-test/MigrationOnlyTest.hs b/persistent-test/MigrationOnlyTest.hs index abc040685..506490017 100644 --- a/persistent-test/MigrationOnlyTest.hs +++ b/persistent-test/MigrationOnlyTest.hs @@ -9,7 +9,7 @@ import qualified Data.Text as T import Init -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL mkPersist persistSettings [persistUpperCase| #else share [mkPersist sqlSettings, mkMigrate "migrateAll1"] [persistLowerCase| @@ -21,7 +21,7 @@ TwoField1 sql=two_field deriving Eq Show |] -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL mkPersist persistSettings [persistUpperCase| #else share [mkPersist sqlSettings, mkMigrate "migrateAll2", mkDeleteCascade sqlSettings] [persistLowerCase| @@ -40,7 +40,7 @@ Referencing specs :: Spec specs = describe "migration only" $ do it "works" $ asIO $ runResourceT $ runConn $ do -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL _ <- runMigrationSilent migrateAll1 _ <- runMigrationSilent migrateAll2 #endif diff --git a/persistent-test/MigrationTest.hs b/persistent-test/MigrationTest.hs index 7546d9805..98239ff82 100644 --- a/persistent-test/MigrationTest.hs +++ b/persistent-test/MigrationTest.hs @@ -9,7 +9,7 @@ import qualified Data.Text as T import Init -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL mkPersist persistSettings [persistUpperCase| #else share [mkPersist sqlSettings, mkMigrate "migrationMigrate", mkDeleteCascade sqlSettings] [persistLowerCase| @@ -25,7 +25,7 @@ Source field4 TargetId |] -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL specs :: Spec specs = describe "Migration" $ do it "is idempotent" $ db $ do diff --git a/persistent-test/PersistentTest.hs b/persistent-test/PersistentTest.hs index ca4e1e53d..cddcd9610 100644 --- a/persistent-test/PersistentTest.hs +++ b/persistent-test/PersistentTest.hs @@ -24,9 +24,11 @@ import Test.Hspec.QuickCheck(prop) import Database.Persist +#ifdef WITH_NOSQL #ifdef WITH_MONGODB import qualified Database.MongoDB as MongoDB import Database.Persist.MongoDB (toInsertDoc, docToEntityThrow, collectionName, recordToDocument) +#endif #else @@ -70,7 +72,7 @@ import Data.Functor.Constant import PersistTestPetType import PersistTestPetCollarType -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL mkPersist persistSettings [persistUpperCase| #else share [mkPersist persistSettings, mkMigrate "testMigrate", mkDeleteCascade persistSettings, mkSave "_ignoredSave"] [persistUpperCase| @@ -147,7 +149,7 @@ deriving instance Show (BackendKey backend) => Show (PetGeneric backend) deriving instance Eq (BackendKey backend) => Eq (PetGeneric backend) share [mkPersist persistSettings { mpsPrefixFields = False, mpsGeneric = False } -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL ] [persistUpperCase| #else , mkMigrate "noPrefixMigrate" @@ -177,7 +179,7 @@ cleanDB = do deleteWhere ([] :: [Filter User]) deleteWhere ([] :: [Filter Email]) -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL db :: Action IO () -> Assertion db = db' cleanDB #endif @@ -268,7 +270,7 @@ specs = describe "persistent" $ do p28 <- updateGet micK [PersonAge =. 28] personAge p28 @== 28 -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL updateWhere [PersonName ==. "Michael"] [PersonAge =. 29] #else uc <- updateWhereCount [PersonName ==. "Michael"] [PersonAge =. 29] @@ -302,7 +304,11 @@ specs = describe "persistent" $ do delete micK Nothing <- get micK return () - +#ifdef WITH_ZOOKEEPER + -- zookeeper backend does not support idfield + -- zookeeper's key is node-name. + -- When uniq-key exists, zookeeper's key becomes encoded uniq-key. +#else it "persistIdField" $ db $ do let p = Person "foo" 100 (Just "blue") q = Person "bar" 101 Nothing @@ -314,6 +320,7 @@ specs = describe "persistent" $ do mq <- selectFirst [persistIdField ==. qk] [] fmap entityVal mq @== Just q +#endif it "!=." $ db $ do deleteWhere ([] :: [Filter Person]) @@ -425,10 +432,19 @@ specs = describe "persistent" $ do Just p <- get key3 p3 @== p +#ifdef WITH_ZOOKEEPER + it "toPathPiece . fromPathPiece" $ do + -- Below quickcheck causes error of "Cannot convert PersistObjectId to Text." + -- Currently, ZooKey does not support PersistObjectId. + let key1 = ZooKey "hogehogekey" :: (BackendKey BackendMonad) + key2 = fromJust $ fromPathPiece $ toPathPiece key1 :: (BackendKey BackendMonad) + toPathPiece key1 `shouldBe` toPathPiece key2 +#else prop "toPathPiece . fromPathPiece" $ \piece -> let key1 = piece :: (BackendKey BackendMonad) key2 = fromJust $ fromPathPiece $ toPathPiece key1 :: (BackendKey BackendMonad) in toPathPiece key1 == toPathPiece key2 +#endif it "replace" $ db $ do key2 <- insert $ Person "Michael2" 27 Nothing @@ -509,7 +525,7 @@ specs = describe "persistent" $ do keyNoAge <- insert noAge noAge2 <- updateGet keyNoAge [PersonMaybeAgeAge +=. Just 2] -- the correct answer is very debatable -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL personMaybeAgeAge noAge2 @== Just 2 #else personMaybeAgeAge noAge2 @== Nothing @@ -689,6 +705,11 @@ specs = describe "persistent" $ do Just (OutdoorPet _ collar' _) <- get catKey liftIO $ collar' @?= mittensCollar +#ifdef WITH_ZOOKEEPER + -- zookeeper backend does not support idfield + -- zookeeper's key is node-name. + -- When uniq-key exists, zookeeper's key becomes encoded uniq-key. +#else it "idIn" $ db $ do let p1 = Person "D" 0 Nothing p2 = Person "E" 1 Nothing @@ -698,6 +719,7 @@ specs = describe "persistent" $ do pid3 <- insert p3 x <- selectList [PersonId <-. [pid1, pid3]] [] liftIO $ x @?= [Entity pid1 p1, Entity pid3 p3] +#endif describe "toJSON" $ do it "serializes" $ db $ do @@ -714,6 +736,7 @@ specs = describe "persistent" $ do -} +#ifdef WITH_NOSQL #ifdef WITH_MONGODB describe "raw MongoDB helpers" $ do it "collectionName" $ do @@ -732,6 +755,7 @@ specs = describe "persistent" $ do MongoDB.save "Person" doc2 Entity _ ent2 <- docToEntityThrow doc2 liftIO $ p2 @?= ent2 +#endif #else it "rawSql/2+2" $ db $ do ret <- rawSql "SELECT 2+2" [] @@ -819,7 +843,7 @@ specs = describe "persistent" $ do #ifndef WITH_MYSQL # ifndef WITH_POSTGRESQL -# ifndef WITH_MONGODB +# ifndef WITH_NOSQL it "afterException" $ db $ do let catcher :: Monad m => SomeException -> m () catcher _ = return () @@ -832,7 +856,7 @@ specs = describe "persistent" $ do #endif -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL it "mpsNoPrefix" $ db $ do deleteWhere ([] :: [Filter NoPrefix2]) deleteWhere ([] :: [Filter NoPrefix1]) diff --git a/persistent-test/RenameTest.hs b/persistent-test/RenameTest.hs index a835d922e..236ecb0f0 100644 --- a/persistent-test/RenameTest.hs +++ b/persistent-test/RenameTest.hs @@ -2,7 +2,7 @@ {-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} module RenameTest (specs) where -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import Control.Monad.Trans.Resource (runResourceT) @@ -23,7 +23,7 @@ instance FromJSON Day where parseJSON = error "Day.parseJSON" type TextId = Text -- Test lower case names -#if WITH_MONGODB +#if WITH_NOSQL mkPersist persistSettings [persistUpperCase| #else share [mkPersist sqlSettings, mkMigrate "lowerCaseMigrate"] [persistLowerCase| @@ -51,8 +51,8 @@ RefTable text TextId UniqueRefTable someVal |] -#if WITH_MONGODB -cleanDB :: ReaderT MongoContext IO () +#if WITH_NOSQL +cleanDB :: ReaderT Context IO () cleanDB = do deleteWhere ([] :: [Filter IdTable]) deleteWhere ([] :: [Filter LowerCaseTable]) @@ -63,7 +63,7 @@ db = db' cleanDB specs :: Spec specs = describe "rename specs" $ do -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL it "handles lower casing" $ asIO $ runConn $ do _ <- runMigration lowerCaseMigrate @@ -82,7 +82,7 @@ specs = describe "rename specs" $ do Just rec' <- get key rec' @== rec -# ifndef WITH_MONGODB +# ifndef WITH_NOSQL -- this uses default= it "user specified id, default=" $ db $ do let rec = IdTable "Foo" diff --git a/persistent-test/SumTypeTest.hs b/persistent-test/SumTypeTest.hs index df34a7a2f..8b42c03e2 100644 --- a/persistent-test/SumTypeTest.hs +++ b/persistent-test/SumTypeTest.hs @@ -10,7 +10,7 @@ import qualified Data.Text as T import Init -#if WITH_MONGODB +#if WITH_NOSQL mkPersist persistSettings [persistLowerCase| #else share [mkPersist persistSettings, mkMigrate "sumTypeMigrate"] [persistLowerCase| @@ -34,7 +34,7 @@ deriving instance Eq (BackendKey backend) => Eq (VehicleGeneric backend) specs :: Spec specs = describe "sum types" $ it "works" $ asIO $ runResourceT $ runConn $ do -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL _ <- runMigrationSilent sumTypeMigrate #endif car1 <- insert $ Car "Ford" "Thunderbird" diff --git a/persistent-test/UniqueTest.hs b/persistent-test/UniqueTest.hs index e88857a6f..f3b0820cd 100644 --- a/persistent-test/UniqueTest.hs +++ b/persistent-test/UniqueTest.hs @@ -2,11 +2,11 @@ module UniqueTest where import Init -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL import Control.Monad (void) #endif -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL mkPersist persistSettings [persistUpperCase| #else share [mkPersist sqlSettings, mkMigrate "uniqueMigrate"] [persistLowerCase| @@ -20,7 +20,7 @@ share [mkPersist sqlSettings, mkMigrate "uniqueMigrate"] [persistLowerCase| fieldB Int Maybe UniqueTestNull fieldA fieldB !force deriving Eq Show -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL TestCheckmark name Text value Text @@ -29,7 +29,7 @@ share [mkPersist sqlSettings, mkMigrate "uniqueMigrate"] [persistLowerCase| deriving Eq Show #endif |] -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend TestNonNull ~ backend) => ReaderT backend m () cleanDB = do deleteWhere ([] :: [Filter TestNonNull]) @@ -41,7 +41,7 @@ db = db' cleanDB specs :: Spec specs = describe "uniqueness constraints" $ -#ifdef WITH_MONGODB +#ifdef WITH_NOSQL return () #else do diff --git a/persistent-test/persistent-sqlite b/persistent-test/persistent-sqlite index 98990887e..40e4880b6 120000 --- a/persistent-test/persistent-sqlite +++ b/persistent-test/persistent-sqlite @@ -1 +1 @@ -../persistent-sqlite/ \ No newline at end of file +../persistent-sqlite \ No newline at end of file diff --git a/persistent-test/persistent-test.cabal b/persistent-test/persistent-test.cabal index a504221ed..3e49eded8 100644 --- a/persistent-test/persistent-test.cabal +++ b/persistent-test/persistent-test.cabal @@ -17,6 +17,10 @@ extra-source-files: test/main.hs test/from-cabal +Flag zookeeper + Description: test only Zookeeper. default is to test just sqlite. + Default: False + Flag mongodb Description: test only MongoDB. default is to test just sqlite. Default: False @@ -149,7 +153,7 @@ library if flag(nooverlap) cpp-options: -DNO_OVERLAP - if !flag(postgresql) && !flag(mysql) && !flag(mongodb) + if !flag(postgresql) && !flag(mysql) && !flag(mongodb) && !flag(zookeeper) exposed-modules: Database.Persist.Sqlite Database.Sqlite @@ -193,15 +197,33 @@ library , process hs-source-dirs: persistent-mongoDB - cpp-options: -DWITH_MONGODB -DDEBUG + cpp-options: -DWITH_NOSQL -DWITH_MONGODB -DDEBUG exposed-modules: Database.Persist.MongoDB + if flag(zookeeper) + build-depends: + hzk >= 2.1.0 + , binary + , utf8-string >= 0.3.7 && < 0.4.0 + , process + + hs-source-dirs: persistent-zookeeper + cpp-options: -DWITH_NOSQL -DWITH_ZOOKEEPER -DDEBUG + exposed-modules: + Database.Persist.Zookeeper + other-modules: Database.Persist.Zookeeper.Config + Database.Persist.Zookeeper.Internal + Database.Persist.Zookeeper.Store + Database.Persist.Zookeeper.Unique + Database.Persist.Zookeeper.Query + Database.Persist.Zookeeper.ZooUtil + Database.Persist.Zookeeper.Binary if flag(couchdb) build-depends: CouchDB >= 1.2 - cpp-options: -DWITH_COUCHDB -DDEBUG + cpp-options: -DWITH_NOSQL -DWITH_COUCHDB -DDEBUG exposed-modules: Database.Persist.CouchDB if flag(high_precision_date) @@ -224,8 +246,10 @@ test-suite test , resourcet , scientific + if flag(zookeeper) + cpp-options: -DWITH_NOSQL -DWITH_ZOOKEEPER -DDEBUG if flag(mongodb) - cpp-options: -DWITH_MONGODB -DDEBUG + cpp-options: -DWITH_NOSQL -DWITH_MONGODB -DDEBUG if flag(postgresql) cpp-options: -DWITH_POSTGRESQL if flag(mysql) diff --git a/persistent-test/persistent-zookeeper b/persistent-test/persistent-zookeeper new file mode 120000 index 000000000..8a1f46ae5 --- /dev/null +++ b/persistent-test/persistent-zookeeper @@ -0,0 +1 @@ +../persistent-zookeeper \ No newline at end of file diff --git a/persistent-test/test/main.hs b/persistent-test/test/main.hs index f09c4c994..1463f6cb5 100644 --- a/persistent-test/test/main.hs +++ b/persistent-test/test/main.hs @@ -26,8 +26,7 @@ import Control.Monad.Trans.Resource (runResourceT) import Control.Exception (handle, IOException) -#ifdef MongoDB -setup = setupMongo +#ifdef WITH_NOSQL #else import Database.Persist.Sql (printMigration, runMigrationUnsafe) @@ -42,7 +41,7 @@ toExitCode False = ExitFailure 1 main :: IO () main = do -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL handle (\(_ :: IOException) -> return ()) $ removeFile $ fromText sqlite_database @@ -76,7 +75,7 @@ main = do EmptyEntityTest.specs CompositeTest.specs -#ifndef WITH_MONGODB +#ifndef WITH_NOSQL MigrationTest.specs PersistentTest.specs #endif diff --git a/persistent-zookeeper/Database/Persist/Zookeeper.hs b/persistent-zookeeper/Database/Persist/Zookeeper.hs new file mode 100644 index 000000000..e97254858 --- /dev/null +++ b/persistent-zookeeper/Database/Persist/Zookeeper.hs @@ -0,0 +1,10 @@ +module Database.Persist.Zookeeper + ( module Database.Persist.Zookeeper.Config + , module Database.Persist.Zookeeper.Store + , module Database.Persist.Zookeeper.Query + ) where + +import Database.Persist.Zookeeper.Config +import Database.Persist.Zookeeper.Store +import Database.Persist.Zookeeper.Unique() +import Database.Persist.Zookeeper.Query diff --git a/persistent-zookeeper/Database/Persist/Zookeeper/Binary.hs b/persistent-zookeeper/Database/Persist/Zookeeper/Binary.hs new file mode 100644 index 000000000..41e501e48 --- /dev/null +++ b/persistent-zookeeper/Database/Persist/Zookeeper/Binary.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE OverloadedStrings #-} +module Database.Persist.Zookeeper.Binary( + toValue +, fromValue +) 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(..), getWord8, Get) +import qualified Data.Binary as Q +import Data.Text (Text, unpack) +import qualified Data.Text as T +import Database.Persist.Types +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.UTF8 as U + +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 (PersistZonedTime x)) = do + -- put (13 :: Word8) + -- put (BinZT x) + + put (BinPersistValue (PersistDbSpecific _)) = undefined + put (BinPersistValue (PersistObjectId x)) = do + put (14 :: Word8) + put x + + 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) + 14-> liftM PersistObjectId (Q.get :: Get B.ByteString) + _ -> fail "Incorrect tag came to Binary deserialization" + liftM BinPersistValue pv + +toValue :: [PersistValue] -> B.ByteString +toValue values = L.toStrict . Q.encode $ map BinPersistValue values + +fromValue' :: B.ByteString -> [BinPersistValue] +fromValue' bin = Q.decode $ L.fromStrict bin + +fromValue :: B.ByteString -> [PersistValue] +fromValue bin = map unBinPersistValue $ fromValue' bin + diff --git a/persistent-zookeeper/Database/Persist/Zookeeper/Config.hs b/persistent-zookeeper/Database/Persist/Zookeeper/Config.hs new file mode 100644 index 000000000..2b04138fb --- /dev/null +++ b/persistent-zookeeper/Database/Persist/Zookeeper/Config.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes, TypeFamilies, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Database.Persist.Zookeeper.Config( + ZookeeperConf(..) +, Connection +, Action +, execZookeeper +, withZookeeperPool +, runZookeeperPool +, defaultZookeeperConf +, defaultZookeeperSettings +) where + +import Database.Persist +import Database.Persist.TH +import Language.Haskell.TH +import qualified Database.Zookeeper as Z +import qualified Database.Zookeeper.Pool as Z +import Data.Pool +import Data.Aeson +import Control.Monad () +import Control.Monad.IO.Class +import Control.Monad.Trans.Control +import Control.Monad.Reader +import Data.Scientific() -- we require only RealFrac instance of Scientific +import Data.Time +import Control.Exception +import Control.Concurrent + +-- | Information required to connect to a Zookeeper server +data ZookeeperConf = ZookeeperConf { + zCoord :: String + , zTimeout :: Z.Timeout + , zNumStripes :: Int + , zIdleTime :: NominalDiffTime + , zMaxResources :: Int +} deriving (Show) + +type Connection = Pool Z.Zookeeper +type Action = ReaderT Z.Zookeeper + +instance HasPersistBackend Z.Zookeeper Z.Zookeeper where + persistBackend = id + +execZookeeper :: (Read a,Show a,Monad m, MonadIO m) => (Z.Zookeeper -> IO (Either Z.ZKError a)) -> Action m a +execZookeeper action = do + s <- ask + liftIO $ waitConnectedState s + r <- liftIO $ action s + case r of + (Right x) -> return x + (Left x) -> liftIO $ throwIO $ userError $ "Zookeeper error: code" ++ show x --fail $ show x + where + waitConnectedState zh = do + s <- Z.getState zh + case s of + Z.ConnectingState -> do + threadDelay (50*1000) + _ -> return () + +-- | Run a connection reader function against a Zookeeper configuration +withZookeeperPool :: (Monad m, MonadIO m) => ZookeeperConf -> (Connection -> m a) -> m a +withZookeeperPool conf connectionReader = do + conn <- liftIO $ createPoolConfig conf + connectionReader conn + +runZookeeperPool :: MonadBaseControl IO m => + Action m b -> Connection -> m b +runZookeeperPool action pool = withResource pool (\stat -> runReaderT action stat) + +defaultZookeeperConf :: ZookeeperConf +defaultZookeeperConf = ZookeeperConf "localhost:2181" 300000 1 300000 30 + +defaultZookeeperSettings :: MkPersistSettings +defaultZookeeperSettings = (mkPersistSettings $ ConT ''Z.Zookeeper) + +instance PersistConfig ZookeeperConf where + type PersistConfigBackend ZookeeperConf = Action + type PersistConfigPool ZookeeperConf = Connection + + loadConfig (Object o) = do + coord <- o .:? "coord" .!= "localhost:2181/" + timeout <- o .:? "timeout" .!= 300000 + numstripes <- o .:? "num-stripes" .!= 1 + (idletime :: Int) <- o .:? "idletime" .!= 300000 + maxresources <- o .:? "max-resource" .!= 30 + + return ZookeeperConf { + zCoord = coord + , zTimeout = timeout + , zNumStripes = numstripes + , zIdleTime = fromIntegral idletime + , zMaxResources = maxresources + } + + loadConfig _ = mzero + + createPoolConfig (ZookeeperConf h t s idle maxres ) = + Z.connect h t Nothing Nothing s idle maxres + + runPool _ = runZookeeperPool diff --git a/persistent-zookeeper/Database/Persist/Zookeeper/Internal.hs b/persistent-zookeeper/Database/Persist/Zookeeper/Internal.hs new file mode 100644 index 000000000..9017da635 --- /dev/null +++ b/persistent-zookeeper/Database/Persist/Zookeeper/Internal.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE OverloadedStrings #-} +module Database.Persist.Zookeeper.Internal + where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Monoid +import Data.Maybe +import qualified Data.Aeson as A +import qualified Data.Text as T +import Database.Persist.Types +import Database.Persist.Class +import Database.Persist.Zookeeper.Binary +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.ByteString.Base64.URL as B64 +import qualified Data.Map as M + + + +txtToKey :: (PersistEntity val) => String -> Key val +txtToKey txt = + case (keyFromValues [PersistText (T.pack txt)]) of + Right v -> v + Left _v -> + case B64.decode $ B.pack txt of + Left v -> error $ v + Right v' -> + case A.decode $ BL.fromStrict v' of + Just values -> + case (keyFromValues values) of + Right v -> v + Left v -> error $ T.unpack v + Nothing -> error "failed" + +keyToTxt :: (PersistEntity val) => Key val -> String +keyToTxt key = + case keyToValues key of + [PersistText txt] -> T.unpack txt + v -> B.unpack $ B64.encode $ BL.toStrict $ A.encode $ v + +dummyFromKey :: Key v -> Maybe v +dummyFromKey _ = Nothing + +dummyFromFList :: [Filter v] -> v +dummyFromFList _ = error "huga" + +dummyFromUnique :: Unique v -> Maybe v +dummyFromUnique _ = Nothing + +val2table :: (PersistEntity val) => val -> T.Text +val2table = unDBName . entityDB . entityDef . Just + +uniqkey2key :: (PersistEntity val) => Unique val -> Key val +uniqkey2key uniqkey = txtToKey $ (B.unpack $ B64.encode $ BL.toStrict $ A.encode $ persistUniqueToValues uniqkey) + +val2uniqkey :: (MonadIO m, PersistEntity val) => val -> m (Maybe (Unique val)) +val2uniqkey val = do + case persistUniqueKeys val of + (uniqkey:_) -> return $ Just uniqkey + [] -> return Nothing + +entity2bin :: (PersistEntity val) => val -> B.ByteString +entity2bin val = toValue (map toPersistValue (toPersistFields val)) + +bin2entity :: (PersistEntity val) => B.ByteString -> Maybe val +bin2entity bin = + case fromPersistValues (fromValue bin) of + Right body -> Just $ body + Left s -> error $ T.unpack s + +entity2path :: (PersistEntity val) => val -> String +entity2path val = "/" <> (T.unpack $ val2table val) + +key2path :: (PersistEntity val) => Key val -> String +key2path key = entity2path $ fromJust $ dummyFromKey key + +filter2path :: (PersistEntity val) => [Filter val] -> String +filter2path filterList = entity2path $ dummyFromFList filterList + +getMap :: PersistEntity val => val -> M.Map T.Text PersistValue +getMap val = M.fromList $ getList val + +getList :: PersistEntity val => val -> [(T.Text,PersistValue)] +getList val = + let fields = fmap toPersistValue (toPersistFields val) + in zip (getFieldsName val) fields + +getFieldsName :: (PersistEntity val) => val -> [T.Text] +getFieldsName val = fmap (unDBName.fieldDB) $ entityFields $ entityDef $ Just val + +getFieldName :: (PersistEntity val) => EntityField val typ -> T.Text +getFieldName field = unDBName $ fieldDB $ persistFieldDef $ field + +fieldval :: (PersistEntity val) => EntityField val typ -> val -> PersistValue +fieldval field val = (getMap val) M.! (getFieldName field) + +updateEntity :: PersistEntity val => val -> [Update val] -> Either T.Text val +updateEntity val upds = + fromPersistValues $ map snd $ foldl updateVals (getList val) upds + +updateVals :: PersistEntity val => [(T.Text,PersistValue)] -> Update val -> [(T.Text,PersistValue)] +updateVals [] _ = [] +updateVals ((k,v):xs) u@(Update field _ _) = + if getFieldName field == k + then (k,updateVal v u):xs + else (k,v):updateVals xs u +updateVals a _ = error $"not supported vals:" ++ show a + +updateVal :: PersistEntity val => PersistValue -> Update val -> PersistValue +updateVal _org (BackendUpdate _) = error $ "BackendUpdate is not supported." +updateVal org (Update _ val upd) = + case upd of + Assign -> pval + Add -> numAdd org pval + Subtract -> numSub org pval + Multiply -> numMul org pval + Divide -> numDiv org pval + BackendSpecificUpdate _ -> error $ "BackendSpecificUpdate is not supported." + where + pval = toPersistValue val + numAdd (PersistInt64 l) (PersistInt64 r) = (PersistInt64 (l + r)) + numAdd (PersistNull) (PersistInt64 r) = (PersistInt64 r) + numAdd (PersistDouble l) (PersistDouble r) = (PersistDouble (l + r)) + numAdd (PersistNull) (PersistDouble r) = (PersistDouble r) + numAdd o _ = error $ "not support : " ++ show o + numSub (PersistInt64 l) (PersistInt64 r) = (PersistInt64 (l - r)) + numSub (PersistNull) (PersistInt64 r) = (PersistInt64 (0 - r)) + numSub (PersistDouble l) (PersistDouble r) = (PersistDouble (l - r)) + numSub (PersistNull) (PersistDouble r) = (PersistDouble (0 - r)) + numSub _ _ = error "not support" + numMul (PersistInt64 l) (PersistInt64 r) = (PersistInt64 (l * r)) + numMul (PersistNull) (PersistInt64 r) = (PersistInt64 (0 * r)) + numMul (PersistDouble l) (PersistDouble r) = (PersistDouble (l * r)) + numMul (PersistNull) (PersistDouble r) = (PersistDouble (0 * r)) + numMul _ _ = error "not support" + numDiv (PersistInt64 l) (PersistInt64 r) = (PersistInt64 (l `div` r)) + numDiv (PersistNull) (PersistInt64 r) = (PersistInt64 (0 `div` r)) + numDiv (PersistDouble l) (PersistDouble r) = (PersistDouble (l / r)) + numDiv (PersistNull) (PersistDouble r) = (PersistDouble (0 / r)) + numDiv _ _ = error "not support" diff --git a/persistent-zookeeper/Database/Persist/Zookeeper/Query.hs b/persistent-zookeeper/Database/Persist/Zookeeper/Query.hs new file mode 100644 index 000000000..2cff830fd --- /dev/null +++ b/persistent-zookeeper/Database/Persist/Zookeeper/Query.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Database.Persist.Zookeeper.Query + where + +import Database.Persist +import Data.Monoid +import qualified Data.List as L +import Control.Monad +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Reader +import qualified Data.Text as T +import qualified Database.Zookeeper as Z +import Database.Persist.Zookeeper.Config +import Database.Persist.Zookeeper.Internal +import Database.Persist.Zookeeper.Store () +import Database.Persist.Zookeeper.ZooUtil +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Acquire + +instance PersistQuery Z.Zookeeper where + updateWhere filterList valList = do + stat <- ask + srcRes <- selectKeysRes filterList [] + liftIO $ with srcRes ( $$ loop stat) + where + loop stat = do + key <- await + case key of + Just key' -> do + liftIO $ flip runReaderT stat $ update key' valList + loop stat + Nothing -> + return () + + deleteWhere filterList = do + (str::[String]) <- execZookeeper $ \zk -> do + zGetChildren zk (filter2path filterList) + loop str + where + loop [] = return () + loop (x:xs) = do + let key = txtToKey x + case filterList of + [] -> delete key + _ -> del key + loop xs + del key = do + va <- get key + case va of + Nothing -> return () + Just v -> do + let (chk,_,_) = filterClause v filterList + if chk + then delete key + else return () + + selectSourceRes filterList opt = do + stat <- ask + (str::[String]) <- liftIO $ flip runReaderT stat $ do + keys <- execZookeeper $ \zk -> do + Z.getChildren zk (filter2path filterList) Nothing + selectOptParser keys opt + return $ return $ loop stat str + where + loop _ [] = return () + loop stat (x:xs) = do + let key = txtToKey x + va <- liftIO $ flip runReaderT stat $ get key + case va of + Nothing -> return () + Just v -> do + let (chk,_,_) = filterClause v filterList + if chk + then yield $ Entity key v + else return () + loop stat xs + + selectFirst filterList opt = do + srcRes <- selectSourceRes filterList opt + liftIO $ with srcRes ( $$ CL.head) + + selectKeysRes filterList opt = do + stat <- ask + (str::[String]) <- liftIO $ flip runReaderT stat $ do + keys <- execZookeeper $ \zk -> do + Z.getChildren zk (filter2path filterList) Nothing + selectOptParser keys opt + return $ return (loop stat str) + where + loop _ [] = return () + loop stat (x:xs) = do + let key = txtToKey x + va <- liftIO $ flip runReaderT stat $ get key + case va of + Nothing -> return () + Just v -> do + let (chk,_,_) = filterClause v filterList + if chk + then yield key + else return () + loop stat xs + + count filterList = do + v <- selectList filterList [] + return $ length v + +dummyFromFilts :: [Filter v] -> Maybe v +dummyFromFilts _ = Nothing + +data OrNull = OrNullYes | OrNullNo + +filterClauseHelper :: PersistEntity val + => Bool -- ^ include WHERE? + -> OrNull + -> val + -> [Filter val] + -> (Bool, T.Text, [PersistValue]) +filterClauseHelper includeWhere orNull val filters = + (bool, if not (T.null sql) && includeWhere + then " WHERE " <> sql + else sql, vals) + where + (bool, sql, vals) = combineAND filters + combineAND = combine " AND " (&&) + combineOR = combine " OR " (||) + + combine s op fs = + (foldr1 op c ,T.intercalate s $ map wrapP a, mconcat b) + where + (c, a, b) = unzip3 $ map go fs + wrapP x = T.concat ["(", x, ")"] + go (BackendFilter _) = error "BackendFilter not expected" + go (FilterAnd []) = (True,"1=1", []) + go (FilterAnd fs) = combineAND fs + go (FilterOr []) = (False,"1=0", []) + go (FilterOr fs) = combineOR fs + go (Filter field value pfilter) = + (showSqlFilter' pfilter (fieldval field val) allVals, + name <> ":" + <> T.pack (show (fieldval field val)) <> ":" + <> showSqlFilter pfilter + <> T.pack (show (showSqlFilter' pfilter (fieldval field val) allVals)) + <> "?5:" <> T.pack (show allVals) <> orNullSuffix, allVals) + where + filterValueToPersistValues :: forall a. PersistField a => Either a [a] -> [PersistValue] + filterValueToPersistValues v = map toPersistValue $ either return id v + + orNullSuffix = + case orNull of + OrNullYes -> mconcat [" OR ", name, " IS NULL"] + OrNullNo -> "" + + allVals = filterValueToPersistValues value + name = unDBName $ fieldDB $ persistFieldDef field + showSqlFilter Eq = "=" + showSqlFilter Ne = "<>" + showSqlFilter Gt = ">" + showSqlFilter Lt = "<" + showSqlFilter Ge = ">=" + showSqlFilter Le = "<=" + showSqlFilter In = " IN " + showSqlFilter NotIn = " NOT IN " + showSqlFilter (BackendSpecificFilter s) = s + showSqlFilter' :: PersistFilter -> PersistValue -> [PersistValue] -> Bool + showSqlFilter' Eq a b = (==) a (head b) + showSqlFilter' Ne a b = (/=) a (head b) + showSqlFilter' Gt a b = (>) a (head b) + showSqlFilter' Lt a b = (<) a (head b) + showSqlFilter' Ge a b = (>=) a (head b) + showSqlFilter' Le a b = (<=) a (head b) + showSqlFilter' In _ [] = False + showSqlFilter' In a (x:xs) = if a==x then True else showSqlFilter' In a xs + showSqlFilter' NotIn _ [] = True + showSqlFilter' NotIn a (x:xs) = if a==x then False else showSqlFilter' NotIn a xs + showSqlFilter' (BackendSpecificFilter _s) _ _ = error "not supported" + +filterClause :: PersistEntity val + => val + -> [Filter val] + -> (Bool, T.Text, [PersistValue]) +filterClause _val [] = (True,"",[]) +filterClause val filter' = filterClauseHelper True OrNullNo val filter' + + +addIdx :: [[String]] -> [(String,Int)] +addIdx keys = concat $ map (\(i,ks) -> map (\k -> (k,i)) ks) $ zip [0..] keys + +delIdx :: [(String,Int)] -> [[String]] +delIdx keys = fstIdx $ L.groupBy cmp keys + where + cmp :: (String,Int) -> (String,Int) -> Bool + cmp (_k0,i0) (_k1,i1) = i0==i1 + +dropIdx :: Int -> [[String]] -> [[String]] +dropIdx num keys = delIdx $ drop num $ addIdx keys + +takeIdx :: Int -> [[String]] -> [[String]] +takeIdx num keys = delIdx $ take num $ addIdx keys + +sortIdx' :: Ord a => Bool -> [(String,a)] -> [[(String,a)]] +sortIdx' asc keys = L.groupBy (\(_k0,i0) (_k1,i1)-> i0==i1) $ L.sortBy (cmp' asc) keys + where + cmp' True (_k0,v0) (_k1,v1) = compare v0 v1 + cmp' False (_k0,v0) (_k1,v1) = compare v1 v0 + +sortIdx :: Ord a => Bool -> [[(String,a)]] -> [[(String,a)]] +sortIdx asc keys = concat $ map (sortIdx' asc) keys + +fstIdx :: Ord a => [[(String,a)]] -> [[String]] +fstIdx keys = flip map keys $ \ks -> flip map ks $ \k -> fst k + +selectOptParser' :: (PersistStore backend, MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val) + => [[String]] + -> [SelectOpt val] + -> ReaderT backend m [[String]] +selectOptParser' keys [] = do + return keys +selectOptParser' keys (OffsetBy i:xs) = do + selectOptParser' (dropIdx i keys) xs +selectOptParser' keys (LimitTo i:xs) = do + selectOptParser' (takeIdx i keys) xs +selectOptParser' keys (Asc field:xs) = do + keysWithVal <- forM keys $ \ks -> do + forM ks $ \k -> do + let key = txtToKey k + val <- get key + case val of + Nothing -> fail "can not get value" + Just v -> return $ (k,fieldval field v) + selectOptParser' (fstIdx $ sortIdx True keysWithVal) xs +selectOptParser' keys (Desc field:xs) = do + keysWithVal <- forM keys $ \ks -> do + forM ks $ \k -> do + let key = txtToKey k + val <- get key + case val of + Nothing -> fail "can not get value" + Just v -> return $ (k,fieldval field v) + selectOptParser' (fstIdx $ sortIdx False keysWithVal) xs + +selectOptParser :: (PersistStore backend, MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val) + => [String] + -> [SelectOpt val] + -> ReaderT backend m [String] +selectOptParser keys opt' = do + keys' <- selectOptParser' [keys] $ selectOpt opt' [] Nothing Nothing + return $ concat keys' + where + selectOpt (opt@(Asc _):opts) sortOpt offset limit = selectOpt opts (sortOpt++[opt]) offset limit + selectOpt (opt@(Desc _):opts) sortOpt offset limit = selectOpt opts (sortOpt++[opt]) offset limit + selectOpt (opt@(LimitTo _):opts) sortOpt offset Nothing = selectOpt opts sortOpt offset (Just opt) + selectOpt (opt@(OffsetBy _):opts) sortOpt Nothing limit = selectOpt opts sortOpt (Just opt) limit + selectOpt (_opt:opts) sortOpt offset limit = selectOpt opts sortOpt offset limit + selectOpt [] sortOpt offset limit = sortOpt ++ maybe [] (\v -> [v]) offset ++ maybe [] (\v -> [v]) limit diff --git a/persistent-zookeeper/Database/Persist/Zookeeper/Store.hs b/persistent-zookeeper/Database/Persist/Zookeeper/Store.hs new file mode 100644 index 000000000..4f6cdb87d --- /dev/null +++ b/persistent-zookeeper/Database/Persist/Zookeeper/Store.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Database.Persist.Zookeeper.Store ( + deleteRecursive +, BackendKey(..) +)where + +import Database.Persist +import qualified Database.Persist.Sql as Sql +import qualified Database.Zookeeper as Z +import Data.Monoid +import qualified Data.Text as T +import Database.Persist.Zookeeper.Config +import Database.Persist.Zookeeper.Internal +import Database.Persist.Zookeeper.ZooUtil +import Control.Monad +import Control.Monad.Reader +import qualified Data.Aeson as A + +import Web.PathPieces (PathPiece (..)) + +-- | ToPathPiece is used to convert a key to/from text +instance PathPiece (BackendKey Z.Zookeeper) where + toPathPiece key = "z" <> (unZooKey key) + fromPathPiece keyText = + case T.uncons keyText of + Just ('z', prefixed) -> Just $ ZooKey prefixed + _ -> mzero + +instance Sql.PersistFieldSql (BackendKey Z.Zookeeper) where + sqlType _ = Sql.SqlOther "doesn't make much sense for Zookeeper" + +instance A.ToJSON (BackendKey Z.Zookeeper) where + toJSON (ZooKey key) = A.toJSON $ "z" <> key + +instance A.FromJSON (BackendKey Z.Zookeeper) where + parseJSON = A.withText "ZooKey" $ \t -> + case T.uncons t of + Just ('z', prefixed) -> return $ ZooKey prefixed + _ -> (fail "Invalid json for zookey") + + +deleteRecursive :: (Monad m, MonadIO m) => String -> Action m () +deleteRecursive dir = execZookeeper $ \zk -> zDeleteRecursive zk dir + + +instance PersistStore Z.Zookeeper where + newtype BackendKey Z.Zookeeper = ZooKey { unZooKey :: T.Text } + deriving (Show, Read, Eq, Ord, PersistField) + + insert val = do + mUniqVal <- val2uniqkey val + case mUniqVal of + Just uniqVal -> do + let key = (uniqkey2key uniqVal) + execZookeeper $ \zk -> do + let dir = entity2path val + r <- zCreate zk dir (keyToTxt key) (Just (entity2bin val)) [] + case r of + Right _ -> return $ Right $ key +-- Left Z.NodeExistsError -> return $ Right $ Nothing + Left v -> return $ Left v + Nothing -> do + let dir = entity2path val + str <- execZookeeper $ \zk -> do + zCreate zk dir "" (Just (entity2bin val)) [Z.Sequence] + return $ txtToKey str + + insertKey key val = do + _ <- execZookeeper $ \zk -> do + let dir = entity2path val + zCreate zk dir (keyToTxt key) (Just (entity2bin val)) [] + return () + + repsert key val = do + _ <- execZookeeper $ \zk -> do + let dir = entity2path val + zRepSert zk dir (keyToTxt key) (Just (entity2bin val)) + return () + + replace key val = do + execZookeeper $ \zk -> do + let dir = entity2path val + _ <- zReplace zk dir (keyToTxt key) (Just (entity2bin val)) + return $ Right () + return () + + delete key = do + execZookeeper $ \zk -> do + let dir = key2path key + _ <- zDelete zk dir (keyToTxt key) Nothing + return $ Right () + return () + + get key = do + r <- execZookeeper $ \zk -> do + let dir = key2path key + val <- zGet zk dir (keyToTxt key) + return $ Right val + case r of + (Left Z.NoNodeError) -> + return Nothing + (Left v) -> + fail $ show v + (Right (Just str,_sta)) -> do + return (bin2entity str) + (Right (Nothing,_stat)) -> do + fail $ "data is nothing" + + update key valList = do + va <- get key + case va of + Nothing -> return () + Just v -> + case updateEntity v valList of + Right v' -> + replace key v' + Left v' -> error $ show v' diff --git a/persistent-zookeeper/Database/Persist/Zookeeper/Unique.hs b/persistent-zookeeper/Database/Persist/Zookeeper/Unique.hs new file mode 100644 index 000000000..276de14ee --- /dev/null +++ b/persistent-zookeeper/Database/Persist/Zookeeper/Unique.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Database.Persist.Zookeeper.Unique + where + +import Database.Persist +import qualified Database.Zookeeper as Z +import Database.Persist.Zookeeper.Internal +import Database.Persist.Zookeeper.Store() + + +instance PersistUnique Z.Zookeeper where + getBy uniqVal = do + let key = uniqkey2key uniqVal + val <- get key + case val of + Nothing -> return Nothing + Just v -> return $ Just $ Entity key v + + deleteBy uniqVal = do + let key = uniqkey2key uniqVal + delete key diff --git a/persistent-zookeeper/Database/Persist/Zookeeper/ZooUtil.hs b/persistent-zookeeper/Database/Persist/Zookeeper/ZooUtil.hs new file mode 100644 index 000000000..07d27410f --- /dev/null +++ b/persistent-zookeeper/Database/Persist/Zookeeper/ZooUtil.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Database.Persist.Zookeeper.ZooUtil + where + +import qualified Database.Zookeeper as Z +import qualified Data.ByteString.Char8 as B +import Control.Monad +import Data.Monoid + +deriving instance Read (Z.ZKError) +deriving instance Read (Z.Stat) + +zGet :: Z.Zookeeper + -> String + -> String + -> IO (Either Z.ZKError (Maybe B.ByteString, Z.Stat)) +zGet zk dir key = do + let path = dir <> "/" <> key + Z.get zk path Nothing + +zSet :: Z.Zookeeper + -> String + -> String + -> Maybe B.ByteString + -> Maybe Z.Version + -> IO (Either Z.ZKError Z.Stat) +zSet zk dir key dat ver = do + let path = dir <> "/" <> key + Z.set zk path dat ver + +zModify :: Z.Zookeeper + -> String + -> String + -> (Maybe B.ByteString -> IO (Maybe B.ByteString)) + -> IO (Either Z.ZKError Z.Stat) +zModify zk dir key f = do + v <- zGet zk dir key + case v of + Right (con,ver) -> do + v'' <- f con + v' <- zSet zk dir key v'' (Just (Z.statVersion ver)) + case v' of + Right _ -> return v' + Left _ -> zModify zk dir key f + Left e -> return $ Left e + +zReplace :: Z.Zookeeper + -> String + -> String + -> (Maybe B.ByteString) + -> IO (Either Z.ZKError Z.Stat) +zReplace zk dir key v'' = do + v <- zGet zk dir key + case v of + Right (_con,ver) -> do + v' <- zSet zk dir key v'' (Just (Z.statVersion ver)) + case v' of + Right _ -> return v' + Left _ -> zReplace zk dir key v'' + Left e -> return $ Left e + +zRepSert :: Z.Zookeeper + -> String + -> String + -> (Maybe B.ByteString) + -> IO (Either Z.ZKError ()) +zRepSert zk dir key v'' = do + v <- zCreate zk dir key v'' [] + case v of + Right _ -> return $ Right () + Left Z.NodeExistsError -> do + v' <- zReplace zk dir key v'' + case v' of + Right _ -> return $ Right () + Left Z.NoNodeError -> do + zRepSert zk dir key v'' + Left s -> do + return $ Left s + Left v' -> return $ Left v' + + +zGetChildren :: Z.Zookeeper + -> String + -> IO (Either Z.ZKError [String]) +zGetChildren zk dir = do + v <- Z.getChildren zk dir Nothing + case v of + Right _ -> return v + Left Z.NoNodeError -> return $ Right [] + Left _ -> return v + +zCreate :: Z.Zookeeper + -> String + -> String + -> Maybe B.ByteString + -> [Z.CreateFlag] + -> IO (Either Z.ZKError String) +zCreate zk dir key value flag = do + let path = dir <> "/" <> key + v <- Z.create zk path value Z.OpenAclUnsafe flag + case v of + Left Z.NoNodeError -> do + v' <- Z.create zk dir Nothing Z.OpenAclUnsafe [] + case v' of + Left _ -> return $ v' + Right _ -> zCreate zk dir key value flag + Left _ -> return v +-- See https://issues.apache.org/jira/browse/ZOOKEEPER-1027 +-- Do not use libzookeeper under 3.3.5, Z.create returns wrong node path +-- Use libzookeeper over 3.4.* + Right path' -> return $ Right $ drop (length ( dir <> "/" )) path' + +zDelete :: Z.Zookeeper + -> String + -> String + -> Maybe Z.Version + -> IO (Either Z.ZKError ()) +zDelete zk dir key mversion = do + let path = dir <> "/" <> key + Z.delete zk path mversion + +zDeleteRecursive :: Z.Zookeeper + -> String + -> IO (Either Z.ZKError ()) +zDeleteRecursive zk dir = do + ls <- zGetTree zk dir + res <- forM (reverse ls) $ \node -> + Z.delete zk node Nothing + return $ checkRes res + where + checkRes [] = Right () + checkRes (Left val:_) = Left val + checkRes (Right _:xs) = checkRes xs + +zGetTree :: Z.Zookeeper + -> String + -> IO [String] +zGetTree zk dir = do + ls <- Z.getChildren zk dir Nothing + case ls of + Right dir' -> do + ls' <- forM dir' $ \d -> do + zGetTree zk (dir <> "/" <> d) + return $ concat ls' + Left err' -> error ("zGetTree's error:" ++ show err') diff --git a/persistent-zookeeper/LICENSE b/persistent-zookeeper/LICENSE new file mode 100644 index 000000000..2d3cdfa19 --- /dev/null +++ b/persistent-zookeeper/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2014, Junji Hashimoto. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/persistent-zookeeper/Setup.hs b/persistent-zookeeper/Setup.hs new file mode 100644 index 000000000..9a994af67 --- /dev/null +++ b/persistent-zookeeper/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/persistent-zookeeper/persistent-zookeeper.cabal b/persistent-zookeeper/persistent-zookeeper.cabal new file mode 100644 index 000000000..304c79267 --- /dev/null +++ b/persistent-zookeeper/persistent-zookeeper.cabal @@ -0,0 +1,87 @@ +name: persistent-zookeeper +version: 0.2.0 +license: BSD3 +license-file: LICENSE +author: Junji Hashimoto +synopsis: Backend for persistent library using Zookeeper. +description: Based on the Zookeeper package. +category: Database +stability: Experimental +cabal-version: >= 1.8 +maintainer: Junji Hashimoto +build-type: Simple + +source-repository head + type: git + location: https://github.com/junjihashimoto/persistent.git + +library + build-depends: base >= 4 && < 5 + , bytestring >= 0.10.0.0 && < 0.11.0.0 + , persistent >= 2.1 + , persistent-template + , template-haskell + , text >= 0.8 + , aeson >= 0.5 + , time >= 1.4 && < 1.5 + , attoparsec + , mtl + , transformers + , transformers-base + , monad-control + , utf8-string >= 0.3.7 && < 0.4.0 + , binary >= 0.7 && < 0.8 + , scientific + , hzk >= 2.1 + , resource-pool + , path-pieces + , template-haskell + , base64-bytestring + , conduit + , containers + , resourcet + , binary + + exposed-modules: Database.Persist.Zookeeper + + other-modules: Database.Persist.Zookeeper.Config + Database.Persist.Zookeeper.Internal + Database.Persist.Zookeeper.Store + Database.Persist.Zookeeper.Unique + Database.Persist.Zookeeper.Query + Database.Persist.Zookeeper.ZooUtil + Database.Persist.Zookeeper.Binary + + ghc-options: -Wall + +test-suite basic + type: exitcode-stdio-1.0 + main-is: tests/basic-test.hs + build-depends: base >= 4 && < 5 + , persistent >= 2.1 + , persistent-template + , mtl + , transformers + , transformers-base + , bytestring >= 0.10.0.0 && < 0.11.0.0 + , text >= 0.8 + , aeson >= 0.5 + , binary >= 0.7 && < 0.8 + , time >= 1.4 && < 1.5 + , attoparsec + , template-haskell + , monad-control + , utf8-string >= 0.3.7 && < 0.4.0 + , persistent-zookeeper + , scientific + , hzk >= 2.1 + , resource-pool + , path-pieces + , base64-bytestring + , hspec + , conduit + , containers + , resourcet + +-- ghc-options: -Wall -ddump-splices + ghc-options: -Wall diff --git a/persistent-zookeeper/tests/basic-test.hs b/persistent-zookeeper/tests/basic-test.hs new file mode 100644 index 000000000..5ce81e8fb --- /dev/null +++ b/persistent-zookeeper/tests/basic-test.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} +{-# LANGUAGE TypeFamilies, EmptyDataDecls, GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Main where + +import Database.Zookeeper () +import Database.Persist +import Database.Persist.Zookeeper +import Database.Persist.Zookeeper.Internal +import Database.Persist.TH +import Language.Haskell.TH.Syntax () +import Data.Maybe +import Data.Pool () +import Test.Hspec + +let zookeeperSettings = defaultZookeeperSettings + in share [mkPersist zookeeperSettings] [persistLowerCase| +Person + name String + age Int + hoge Int Maybe + PersonU name + deriving Show + deriving Eq +|] + +zookeeperConf :: ZookeeperConf +zookeeperConf = ZookeeperConf "localhost:2181" 10000 1 50 30 + +main :: IO () +main = + withZookeeperPool zookeeperConf $ \conn -> do + hspec $ do + let key = txtToKey "WyJzVGVzdC9ob2dlIl0=" + let val = Person "Test/hoge" 12 Nothing + describe "PersistUnique test" $ do + it "insertUnique" $ do + v <- flip runZookeeperPool conn $ do + deleteBy $ PersonU "Test/hoge" + insertUnique val + v `shouldBe` (Just key) + it "getBy" $ do + v <- flip runZookeeperPool conn $ do + getBy $ PersonU "Test/hoge" + (entityKey (fromJust v)) `shouldBe` key + (entityVal (fromJust v)) `shouldBe` val + v `shouldBe` (Just (Entity key val)) + it "deleteBy" $ do + v <- flip runZookeeperPool conn $ do + deleteBy $ PersonU "Test/hoge" + getBy $ PersonU "Test/hoge" + v `shouldBe` Nothing + describe "PersistStore test" $ do + it "StoreTest" $ do + key' <- flip runZookeeperPool conn $ do + insert val + v <- flip runZookeeperPool conn $ do + get key' + print $ show key' + v `shouldBe` (Just val) + v' <- flip runZookeeperPool conn $ do + delete key' + get key' + v' `shouldBe` Nothing + describe "PersistQeuery test" $ do + let check val' filter' expbool = case filterClause val' filter' of + a@(bool,_,_) -> do + print $ show a + bool `shouldBe` expbool + it "FilterTest Filter OR/AND" $ do + check (Person "Test/hoge" 12 Nothing) [FilterOr[]] False + check (Person "Test/hoge" 12 Nothing) [FilterAnd[]] True + it "FilterTest Nothing" $ do + check (Person "Test/hoge" 12 Nothing) [] True + check (Person "Test/hoge" 12 (Just 3)) [] True + check (Person "Test/hoge" 12 Nothing) [] True + it "FilterTestEq" $ do + check (Person "Test/hoge" 12 Nothing) [PersonName ==. ""] False + check (Person "Test/hoge" 12 (Just 3)) [PersonHoge ==. Just 3] True + check (Person "Test/hoge" 12 Nothing) [PersonAge ==. 12] True + it "FilterTestNe" $ do + check (Person "Test/hoge" 12 Nothing) [PersonAge !=. 12] False + check (Person "Test/hoge" 12 Nothing) [PersonAge !=. 11] True + check (Person "Test/hoge" 12 (Just 4)) [PersonHoge !=. Just 4] False + check (Person "Test/hoge" 12 Nothing) [PersonHoge !=. Just 3] True + check (Person "Test/hoge" 12 (Just 4)) [PersonHoge !=. Just 3] True + it "FilterTestLt" $ do + check (Person "Test/hoge" 12 (Just 4)) [PersonHoge <=. Just 3] False + check (Person "Test/hoge" 12 (Just 2)) [PersonHoge <=. Just 3] True + it "StoreTest" $ do + va <- flip runZookeeperPool conn $ do + deleteWhere [PersonName !=. ""] + _ <- insert (Person "hoge0" 1 Nothing) + _ <- insert (Person "hoge1" 2 Nothing) + _ <- insert (Person "hoge2" 3 Nothing) + _ <- insert (Person "hoge3" 4 Nothing) + selectList [PersonAge ==. 2] [] + (entityVal (head va)) `shouldBe` (Person "hoge1" 2 Nothing) + [Entity _k v] <- flip runZookeeperPool conn $ do + selectList [PersonName ==. "hoge2"] [] + v `shouldBe` (Person "hoge2" 3 Nothing) + [Entity _k v1] <- flip runZookeeperPool conn $ do + updateWhere [PersonName ==. "hoge2"] [PersonAge =. 10] + selectList [PersonName ==. "hoge2"] [] + v1 `shouldBe` (Person "hoge2" 10 Nothing) + v2 <- flip runZookeeperPool conn $ do + selectList [PersonName !=. ""] [] + length v2 `shouldBe` 4 + v3 <- flip runZookeeperPool conn $ do + deleteWhere [PersonName !=. ""] + selectList [PersonName !=. ""] [] + length v3 `shouldBe` 0 diff --git a/sources.txt b/sources.txt index 11d6db5d9..7f3ac9b58 100644 --- a/sources.txt +++ b/sources.txt @@ -4,3 +4,4 @@ ./persistent-postgresql ./persistent-mysql ./persistent-mongoDB +./persistent-zookeeper