persistent-zookeeper 0.1.0 → 0.2.0
raw patch · 11 files changed
+589/−288 lines, 11 filesdep −stmdep ~binary
Dependencies removed: stm
Dependency ranges changed: binary
Files
- Database/Persist/Zookeeper.hs +1/−4
- Database/Persist/Zookeeper/Binary.hs +169/−0
- Database/Persist/Zookeeper/Config.hs +61/−47
- Database/Persist/Zookeeper/Internal.hs +71/−55
- Database/Persist/Zookeeper/PathPiece.hs +0/−22
- Database/Persist/Zookeeper/Query.hs +113/−31
- Database/Persist/Zookeeper/Store.hs +54/−57
- Database/Persist/Zookeeper/Unique.hs +2/−24
- Database/Persist/Zookeeper/ZooUtil.hs +90/−25
- persistent-zookeeper.cabal +3/−5
- tests/basic-test.hs +25/−18
Database/Persist/Zookeeper.hs view
@@ -1,13 +1,10 @@-module Database.Persist.Zookeeper +module Database.Persist.Zookeeper ( module Database.Persist.Zookeeper.Config , module Database.Persist.Zookeeper.Store- , module Database.Persist.Zookeeper.Unique , module Database.Persist.Zookeeper.Query- , module Database.Persist.Zookeeper.PathPiece ) where import Database.Persist.Zookeeper.Config import Database.Persist.Zookeeper.Store import Database.Persist.Zookeeper.Unique() import Database.Persist.Zookeeper.Query-import Database.Persist.Zookeeper.PathPiece()
+ Database/Persist/Zookeeper/Binary.hs view
@@ -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+
Database/Persist/Zookeeper/Config.hs view
@@ -8,26 +8,32 @@ {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-module Database.Persist.Zookeeper.Config- where+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.Persist.Zookeeper.ZooUtil as Z import qualified Database.Zookeeper as Z import qualified Database.Zookeeper.Pool as Z import Data.Pool import Data.Aeson-import Control.Monad (mzero, MonadPlus(..))-import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Trans.Class (MonadTrans (..))+import Control.Monad ()+import Control.Monad.IO.Class import Control.Monad.Trans.Control-import Control.Applicative (Applicative (..))-import Control.Monad.Reader(ReaderT(..))-import Control.Monad.Reader.Class+import Control.Monad.Reader import Data.Scientific() -- we require only RealFrac instance of Scientific-import Data.Time+import Data.Time+import Control.Exception+import Control.Concurrent -- | Information required to connect to a Zookeeper server data ZookeeperConf = ZookeeperConf {@@ -39,57 +45,65 @@ } deriving (Show) type Connection = Pool Z.Zookeeper+type Action = ReaderT Z.Zookeeper --- | Monad reader transformer keeping Zookeeper connection through out the work-newtype ZookeeperT m a = ZookeeperT { runZookeeperT :: ReaderT Connection m a }- deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadPlus)+instance HasPersistBackend Z.Zookeeper Z.Zookeeper where+ persistBackend = id --- | Extracts connection from ZookeeperT monad transformer-thisConnection :: Monad m => ZookeeperT m Connection-thisConnection = ZookeeperT ask+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-withZookeeperConn :: (Monad m, MonadIO m) => ZookeeperConf -> (Connection -> m a) -> m a-withZookeeperConn conf connectionReader = do- conn <- liftIO $ createPoolConfig conf- connectionReader conn--runZookeeperPool :: ZookeeperT m a -> Connection -> m a-runZookeeperPool (ZookeeperT r) = runReaderT r+withZookeeperPool :: (Monad m, MonadIO m) => ZookeeperConf -> (Connection -> m a) -> m a+withZookeeperPool conf connectionReader = do+ conn <- liftIO $ createPoolConfig conf+ connectionReader conn ---runZookeeper :: ZookeeperT m a -> Connection -> m a-runZookeeper :: MonadBaseControl IO m =>- Connection -> ReaderT Z.Zookeeper m b -> m b-runZookeeper pool action = withResource pool (\stat -> runReaderT action stat)+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" 10000 1 50 30+defaultZookeeperConf = ZookeeperConf "localhost:2181" 300000 1 300000 30 defaultZookeeperSettings :: MkPersistSettings defaultZookeeperSettings = (mkPersistSettings $ ConT ''Z.Zookeeper) instance PersistConfig ZookeeperConf where- type PersistConfigBackend ZookeeperConf = ZookeeperT- type PersistConfigPool ZookeeperConf = Connection+ type PersistConfigBackend ZookeeperConf = Action+ type PersistConfigPool ZookeeperConf = Connection - loadConfig (Object o) = do- coord <- o .:? "coord" .!= "localhost:2181/"- timeout <- o .:? "timeout" .!= 10000- numstripes <- o .:? "num-stripes" .!= 1- (idletime :: Int) <- o .:? "idletime" .!= 30- maxresources <- o .:? "max-resource" .!= 50+ 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- }+ return ZookeeperConf {+ zCoord = coord+ , zTimeout = timeout+ , zNumStripes = numstripes+ , zIdleTime = fromIntegral idletime+ , zMaxResources = maxresources+ } - loadConfig _ = mzero+ loadConfig _ = mzero - createPoolConfig (ZookeeperConf h t s idle maxres ) = - Z.connect h t Nothing Nothing s idle maxres+ createPoolConfig (ZookeeperConf h t s idle maxres ) =+ Z.connect h t Nothing Nothing s idle maxres - runPool _ = runZookeeperPool+ runPool _ = runZookeeperPool
Database/Persist/Zookeeper/Internal.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Database.Persist.Zookeeper.Internal where- + import Control.Monad.IO.Class (MonadIO (..)) import Data.Monoid import Data.Maybe@@ -9,25 +9,34 @@ 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) => T.Text -> Key val-txtToKey txt = - case (keyFromValues [PersistText txt]) of++txtToKey :: (PersistEntity val) => String -> Key val+txtToKey txt =+ case (keyFromValues [PersistText (T.pack txt)]) of Right v -> v- Left v -> error $ T.unpack 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 -> T.Text---keyToTxt (Key (PersistText key)) = key-keyToTxt key = +keyToTxt :: (PersistEntity val) => Key val -> String+keyToTxt key = case keyToValues key of- [PersistText txt] -> txt- _ -> error "keyToTxt"---keyToTxt v = error $ "do not support "++show v+ [PersistText txt] -> T.unpack txt+ v -> B.unpack $ B64.encode $ BL.toStrict $ A.encode $ v dummyFromKey :: Key v -> Maybe v dummyFromKey _ = Nothing@@ -41,84 +50,91 @@ 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 -uniqkey2key :: (PersistEntity val) => Unique val -> Key val-uniqkey2key uniqkey =- let dir = entity2path $ fromJust $ dummyFromUnique uniqkey- in txtToKey $ T.pack $ dir <> "/" <> (B.unpack $ B64.encode $ BL.toStrict $ A.encode $ persistUniqueToValues uniqkey)- entity2bin :: (PersistEntity val) => val -> B.ByteString-entity2bin val = BL.toStrict (A.encode (map toPersistValue (toPersistFields val)))--kv2v :: [PersistValue] -> [PersistValue]-kv2v [] = []-kv2v ((PersistList [_k,v] ):xs) = v:kv2v xs-kv2v (x:xs) = x:kv2v xs+entity2bin val = toValue (map toPersistValue (toPersistFields val)) bin2entity :: (PersistEntity val) => B.ByteString -> Maybe val bin2entity bin =- case A.decode (BL.fromStrict bin) :: Maybe [PersistValue]of- Nothing -> Nothing- Just v ->- case fromPersistValues (kv2v v) of- Right body -> Just $ body- Left s -> error $ T.unpack s- + 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) --- entityAndKey2path :: (PersistEntity val) => val -> Key val -> String--- entityAndKey2path val (Key (PersistText txt)) = entity2path val <> "/" <> ( B.unpack $ B64.encode $ B.pack $ T.unpack txt)--- entityAndKey2path _ _ = error "key is not persist text"---- key2path :: (PersistEntity val) => Key val -> String--- key2path key = entityAndKey2path (fromJust (dummyFromKey key)) key--+key2path :: (PersistEntity val) => Key val -> String+key2path key = entity2path $ fromJust $ dummyFromKey key -filter2path :: (PersistEntity val) => [Filter val] -> String +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 = +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,PersistField typ) => EntityField val typ -> T.Text++getFieldName :: (PersistEntity val) => EntityField val typ -> T.Text getFieldName field = unDBName $ fieldDB $ persistFieldDef $ field-fieldval :: (PersistEntity val,PersistField typ) => EntityField val typ -> val -> PersistValue-fieldval field val = (getMap val) M.! (getFieldName 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 = +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 _ _) = +updateVals ((k,v):xs) u@(Update field _ _) = if getFieldName field == k then (k,updateVal v u):xs else (k,v):updateVals xs u-updateVals _ _ = error "not supported"+updateVals a _ = error $"not supported vals:" ++ show a updateVal :: PersistEntity val => PersistValue -> Update val -> PersistValue-updateVal _v (Update _ val upd) = +updateVal _org (BackendUpdate _) = error $ "BackendUpdate is not supported."+updateVal org (Update _ val upd) = case upd of- Assign -> toPersistValue val- _ -> error "not support"- -- Add -> (+) <$> v <$> toPersistValue val - -- Subtract -> v - toPersistValue val - -- Multiply -> v * toPersistValue val - -- Divide -> v `div` toPersistValue val -updateVal _v _ = error "not supported"-+ 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"
− Database/Persist/Zookeeper/PathPiece.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Database.Persist.Zookeeper.PathPiece- where--import qualified Database.Zookeeper as Z-import Database.Persist-import Database.Persist.Zookeeper.Store-import Database.Persist.Zookeeper.ZooUtil-import Web.PathPieces (PathPiece (..))-import Control.Applicative---- | ToPathPiece is used to convert a key to/from text-instance PathPiece (BackendKey Z.Zookeeper) where- fromPathPiece txt = pure $ ZooKey txt- toPathPiece (ZooKey txt) = txt--
Database/Persist/Zookeeper/Query.hs view
@@ -9,12 +9,15 @@ 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.Store () import Database.Persist.Zookeeper.ZooUtil import Data.Conduit import qualified Data.Conduit.List as CL@@ -34,76 +37,84 @@ loop stat Nothing -> return ()+ deleteWhere filterList = do- (str::[String]) <- execZookeeperT $ \zk -> do- Z.getChildren zk (filter2path filterList) Nothing+ (str::[String]) <- execZookeeper $ \zk -> do+ zGetChildren zk (filter2path filterList) loop str where loop [] = return () loop (x:xs) = do- let key = txtToKey $ T.pack $ (filter2path filterList) <> "/" <> x+ 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 + let (chk,_,_) = filterClause v filterList if chk then delete key else return ()- loop xs- selectSourceRes filterList [] = do++ selectSourceRes filterList opt = do stat <- ask- (str::[String]) <- liftIO $ flip runReaderT stat $ execZookeeperT $ \zk -> do- Z.getChildren zk (filter2path filterList) Nothing+ (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 $ T.pack $ (filter2path filterList) <> "/" <> x+ let key = txtToKey x va <- liftIO $ flip runReaderT stat $ get key case va of Nothing -> return () Just v -> do- let (chk,_,_) = filterClause v filterList + let (chk,_,_) = filterClause v filterList if chk then yield $ Entity key v else return () loop stat xs- selectSourceRes _ _ = error "not supported selectOpt"- selectFirst filterList [] = do- srcRes <- selectSourceRes filterList []++ selectFirst filterList opt = do+ srcRes <- selectSourceRes filterList opt liftIO $ with srcRes ( $$ CL.head)- selectFirst _ _ = error "not supported selectOpt"- selectKeysRes filterList [] = do ++ selectKeysRes filterList opt = do stat <- ask- (str::[String]) <- liftIO $ flip runReaderT stat $ execZookeeperT $ \zk -> - Z.getChildren zk (filter2path filterList) Nothing+ (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 $ T.pack $ (filter2path filterList) <> "/" <> x+ let key = txtToKey x va <- liftIO $ flip runReaderT stat $ get key case va of Nothing -> return () Just v -> do- let (chk,_,_) = filterClause v filterList + let (chk,_,_) = filterClause v filterList if chk then yield key else return () loop stat xs- selectKeysRes _ _ = error "not supported selectOpt"+ 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@@ -127,17 +138,16 @@ go (BackendFilter _) = error "BackendFilter not expected" go (FilterAnd []) = (True,"1=1", []) go (FilterAnd fs) = combineAND fs- go (FilterOr []) = (True,"1=0", [])+ go (FilterOr []) = (False,"1=0", []) go (FilterOr fs) = combineOR fs- go (Filter field value pfilter) = - (showSqlFilter' pfilter (fieldval field val) allVals, + go (Filter field value pfilter) =+ (showSqlFilter' pfilter (fieldval field val) allVals, name <> ":"- <> T.pack (show (fieldval field val)) <> ":" + <> T.pack (show (fieldval field val)) <> ":" <> showSqlFilter pfilter <> T.pack (show (showSqlFilter' pfilter (fieldval field val) allVals))- <> "?5:" <> T.pack (show allVals) <> orNullSuffix, 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 @@ -170,9 +180,81 @@ 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 = filterClauseHelper True OrNullNo val+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
Database/Persist/Zookeeper/Store.hs view
@@ -5,104 +5,102 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-module Database.Persist.Zookeeper.Store where+module Database.Persist.Zookeeper.Store (+ deleteRecursive+, BackendKey(..)+)where import Database.Persist import qualified Database.Persist.Sql as Sql--- import Database.Persist.Class--- import Database.Persist.Types-import Control.Exception-import Control.Applicative-import Control.Monad.IO.Class (MonadIO (..)) import qualified Database.Zookeeper as Z import Data.Monoid import qualified Data.Text as T--- import qualified Data.ByteString.Char8 as B-import Database.Persist.Zookeeper.Config (ZookeeperT(..), thisConnection)+import Database.Persist.Zookeeper.Config import Database.Persist.Zookeeper.Internal import Database.Persist.Zookeeper.ZooUtil-import Data.Pool import Control.Monad import Control.Monad.Reader import qualified Data.Aeson as A ---data ZookeeperBackend-- --- -- | Execute Zookeeper transaction inside ZookeeperT monad transformer-execZookeeperT :: (Read a,Show a,Monad m, MonadIO m) => (Z.Zookeeper -> IO (Either Z.ZKError a)) -> ReaderT Z.Zookeeper m a-execZookeeperT action = do- s <- ask- r <- liftIO $ action s- case r of- (Right x) -> return x- (Left x) -> liftIO $ throwIO $ userError $ "Zookeeper error: code" ++ show x --fail $ show x---- instance PersistField DB.ObjectId where--- toPersistValue = oidToPersistValue--- fromPersistValue oid@(PersistObjectId _) = Right $ persistObjectIdToDbOid oid--- fromPersistValue (PersistByteString bs) = fromPersistValue (PersistObjectId bs)--- fromPersistValue _ = Left $ T.pack "expected PersistObjectId"+import Web.PathPieces (PathPiece (..)) --- instance Sql.PersistFieldSql T.Text where--- sqlType _ = Sql.SqlOther "doesn't make much sense for MongoDB"+-- | 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 MongoDB"+ sqlType _ = Sql.SqlOther "doesn't make much sense for Zookeeper" instance A.ToJSON (BackendKey Z.Zookeeper) where- toJSON (ZooKey key) = A.String key+ toJSON (ZooKey key) = A.toJSON $ "z" <> key instance A.FromJSON (BackendKey Z.Zookeeper) where- parseJSON (A.String key) = pure $ ZooKey key- parseJSON _ = mzero+ 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- --type PersistMonadBackend (ZookeeperT m) = ZookeeperBackend newtype BackendKey Z.Zookeeper = ZooKey { unZooKey :: T.Text } deriving (Show, Read, Eq, Ord, PersistField) insert val = do- let dir = entity2path val- let path = dir <> "/"- str <- execZookeeperT $ \zk -> do- zCreate zk dir path (Just (entity2bin val)) [Z.Sequence]- return $ txtToKey $ T.pack $ str+ 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- _ <- execZookeeperT $ \zk -> do+ _ <- execZookeeper $ \zk -> do let dir = entity2path val- zCreate zk dir (T.unpack (keyToTxt key)) (Just (entity2bin val)) []+ zCreate zk dir (keyToTxt key) (Just (entity2bin val)) [] return () - insertKey _ _ = fail "Wrong key type in insertKey"- repsert key val = do- _ <- execZookeeperT $ \zk -> do+ _ <- execZookeeper $ \zk -> do let dir = entity2path val- zRepSert zk dir (T.unpack (keyToTxt key)) (Just (entity2bin val))+ zRepSert zk dir (keyToTxt key) (Just (entity2bin val)) return ()- repsert _ _ = fail "Wrong key type in repsert" replace key val = do- execZookeeperT $ \zk -> do- _ <- zReplace zk (T.unpack (keyToTxt key)) (Just (entity2bin val))+ execZookeeper $ \zk -> do+ let dir = entity2path val+ _ <- zReplace zk dir (keyToTxt key) (Just (entity2bin val)) return $ Right () return () - replace _ _ = fail "Wrong key type in replace"- delete key = do- execZookeeperT $ \zk -> do- _ <- Z.delete zk (T.unpack (keyToTxt key)) Nothing+ execZookeeper $ \zk -> do+ let dir = key2path key+ _ <- zDelete zk dir (keyToTxt key) Nothing return $ Right () return ()- delete _ = fail "Wrong key type in delete" get key = do- r <- execZookeeperT $ \zk -> do- val <- Z.get zk (T.unpack (keyToTxt key)) Nothing+ r <- execZookeeper $ \zk -> do+ let dir = key2path key+ val <- zGet zk dir (keyToTxt key) return $ Right val case r of (Left Z.NoNodeError) ->@@ -113,14 +111,13 @@ return (bin2entity str) (Right (Nothing,_stat)) -> do fail $ "data is nothing"- - get _ = fail "Wrong key type in get"+ update key valList = do va <- get key case va of Nothing -> return () Just v -> case updateEntity v valList of- Right v' -> + Right v' -> replace key v' Left v' -> error $ show v'
Database/Persist/Zookeeper/Unique.hs view
@@ -8,16 +8,11 @@ where import Database.Persist-import Control.Applicative (Applicative)-import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Trans.Control (MonadBaseControl)-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 Database.Persist.Zookeeper.Store() + instance PersistUnique Z.Zookeeper where getBy uniqVal = do let key = uniqkey2key uniqVal@@ -29,20 +24,3 @@ deleteBy uniqVal = do let key = uniqkey2key uniqVal delete key- - insertUnique val = do- mUniqVal <- val2uniqkey val- case mUniqVal of- Just uniqVal -> do- let key = (uniqkey2key uniqVal)- let txt = keyToTxt key- execZookeeperT $ \zk -> do- let dir = entity2path val- r <- zCreate zk dir (T.unpack txt) (Just (entity2bin val)) []- case r of- Right _ -> return $ Right $ Just key- Left Z.NodeExistsError -> return $ Right $ Nothing- Left v -> return $ Left v- Nothing -> do- return $ Nothing-
Database/Persist/Zookeeper/ZooUtil.hs view
@@ -12,43 +12,59 @@ import qualified Database.Zookeeper as Z import qualified Data.ByteString.Char8 as B--- import qualified Data.ByteString.Lazy as BL-import qualified Data.Pool as P-import Control.Concurrent-import Control.Concurrent.STM-import Data.Time-import Data.Maybe+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- -> (Maybe B.ByteString -> IO (Maybe B.ByteString))- -> IO (Either Z.ZKError Z.Stat)-zModify zk key f = do- v <- Z.get zk key Nothing+ -> 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' <- Z.set zk key v'' (Just (Z.statVersion ver))+ v' <- zSet zk dir key v'' (Just (Z.statVersion ver)) case v' of Right _ -> return v'- Left _ -> zModify zk key f+ Left _ -> zModify zk dir key f Left e -> return $ Left e zReplace :: Z.Zookeeper- -> String- -> (Maybe B.ByteString)- -> IO (Either Z.ZKError Z.Stat)-zReplace zk key v'' = do- v <- Z.get zk key Nothing+ -> 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' <- Z.set zk key v'' (Just (Z.statVersion ver))+ v' <- zSet zk dir key v'' (Just (Z.statVersion ver)) case v' of Right _ -> return v'- Left _ -> zReplace zk key v''+ Left _ -> zReplace zk dir key v'' Left e -> return $ Left e zRepSert :: Z.Zookeeper@@ -61,7 +77,7 @@ case v of Right _ -> return $ Right () Left Z.NodeExistsError -> do- v' <- zReplace zk key v''+ v' <- zReplace zk dir key v'' case v' of Right _ -> return $ Right () Left Z.NoNodeError -> do@@ -70,19 +86,68 @@ 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 path value flag = do+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 v'' -> return $ Left v''- Right _ -> zCreate zk dir path value flag- v' -> return v'+ 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')
persistent-zookeeper.cabal view
@@ -1,5 +1,5 @@ name: persistent-zookeeper-version: 0.1.0+version: 0.2.0 license: BSD3 license-file: LICENSE author: Junji Hashimoto <junji.hashimoto@gree.net>@@ -37,10 +37,10 @@ , path-pieces , template-haskell , base64-bytestring- , stm , conduit , containers , resourcet+ , binary exposed-modules: Database.Persist.Zookeeper @@ -49,8 +49,8 @@ Database.Persist.Zookeeper.Store Database.Persist.Zookeeper.Unique Database.Persist.Zookeeper.Query- Database.Persist.Zookeeper.PathPiece Database.Persist.Zookeeper.ZooUtil+ Database.Persist.Zookeeper.Binary ghc-options: -Wall @@ -63,7 +63,6 @@ , mtl , transformers , transformers-base- , utf8-string >= 0.3.7 && < 0.4.0 , bytestring >= 0.10.0.0 && < 0.11.0.0 , text >= 0.8 , aeson >= 0.5@@ -80,7 +79,6 @@ , path-pieces , base64-bytestring , hspec- , stm , conduit , containers , resourcet
tests/basic-test.hs view
@@ -4,14 +4,14 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Main where -import qualified Database.Zookeeper as Z+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 Language.Haskell.TH.Syntax () import Data.Maybe-import Data.Pool+import Data.Pool () import Test.Hspec let zookeeperSettings = defaultZookeeperSettings@@ -29,37 +29,37 @@ zookeeperConf = ZookeeperConf "localhost:2181" 10000 1 50 30 main :: IO ()-main = - withZookeeperConn zookeeperConf $ \conn -> do+main =+ withZookeeperPool zookeeperConf $ \conn -> do hspec $ do- let key = txtToKey "/person/WyJzVGVzdC9ob2dlIl0="+ let key = txtToKey "WyJzVGVzdC9ob2dlIl0=" let val = Person "Test/hoge" 12 Nothing describe "PersistUnique test" $ do it "insertUnique" $ do- v <- runZookeeper conn $ do+ v <- flip runZookeeperPool conn $ do deleteBy $ PersonU "Test/hoge" insertUnique val v `shouldBe` (Just key) it "getBy" $ do- v <- runZookeeper conn $ do- getBy $ PersonU "Test/hoge" + 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 <- runZookeeper conn $ 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' <- runZookeeper conn $ do+ key' <- flip runZookeeperPool conn $ do insert val- v <- runZookeeper conn $ do+ v <- flip runZookeeperPool conn $ do get key' print $ show key' v `shouldBe` (Just val)- v' <- runZookeeper conn $ do+ v' <- flip runZookeeperPool conn $ do delete key' get key' v' `shouldBe` Nothing@@ -68,6 +68,13 @@ 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@@ -82,7 +89,7 @@ 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 <- runZookeeper conn $ do+ va <- flip runZookeeperPool conn $ do deleteWhere [PersonName !=. ""] _ <- insert (Person "hoge0" 1 Nothing) _ <- insert (Person "hoge1" 2 Nothing)@@ -90,17 +97,17 @@ _ <- insert (Person "hoge3" 4 Nothing) selectList [PersonAge ==. 2] [] (entityVal (head va)) `shouldBe` (Person "hoge1" 2 Nothing)- [Entity _k v] <- runZookeeper conn $ do+ [Entity _k v] <- flip runZookeeperPool conn $ do selectList [PersonName ==. "hoge2"] [] v `shouldBe` (Person "hoge2" 3 Nothing)- [Entity _k v1] <- runZookeeper conn $ do+ [Entity _k v1] <- flip runZookeeperPool conn $ do updateWhere [PersonName ==. "hoge2"] [PersonAge =. 10] selectList [PersonName ==. "hoge2"] [] v1 `shouldBe` (Person "hoge2" 10 Nothing)- v2 <- runZookeeper conn $ do+ v2 <- flip runZookeeperPool conn $ do selectList [PersonName !=. ""] [] length v2 `shouldBe` 4- v3 <- runZookeeper conn $ do+ v3 <- flip runZookeeperPool conn $ do deleteWhere [PersonName !=. ""] selectList [PersonName !=. ""] [] length v3 `shouldBe` 0