hzk (empty) → 0.0.1
raw patch · 7 files changed
+1384/−0 lines, 7 filesdep +basedep +bytestringdep +tastysetup-changed
Dependencies added: base, bytestring, tasty, tasty-hunit
Files
- LICENSE +27/−0
- Setup.hs +3/−0
- hzk.cabal +48/−0
- src/Database/Zookeeper.hs +423/−0
- src/Database/Zookeeper/CApi.hsc +376/−0
- src/Database/Zookeeper/Types.hs +275/−0
- src/test-zookeeper.hs +232/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2013, Diego Souza+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.++ Neither the name of the {organization} nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 HOLDER OR CONTRIBUTORS 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.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ hzk.cabal view
@@ -0,0 +1,48 @@+name: hzk+author: dsouza@c0d3.xxx+license: BSD3+version: 0.0.1+category: Database+homepage: http://github.com/dgvncsz0f/hzk+synopsis: Haskell client library for Apache Zookeeper+build-type: Simple+maintainer: dgvncsz0f+description: A haskell binding to Apache Zookeeper C library+license-file: LICENSE+cabal-version: >= 1.16++source-repository head+ type: git+ branch: master+ location: git://github.com/dgvncsz0f/hzk.git++library+ ghc-options: -rtsopts -W -Wall+ include-dirs: /usr/include/zookeeper+ build-depends: base (>= 4 && < 5)+ , bytestring (>= 0.10 && < 1)+ other-modules: Database.Zookeeper.CApi+ , Database.Zookeeper.Types+ hs-source-dirs: src+ exposed-modules: Database.Zookeeper+ extra-libraries: zookeeper_mt+ default-language: Haskell2010+ default-extensions: ForeignFunctionInterface++test-suite test-zookeeper+ type: exitcode-stdio-1.0+ main-is: test-zookeeper.hs+ ghc-options: -threaded -rtsopts+ include-dirs: /usr/include/zookeeper+ other-modules: Database.Zookeeper + , Database.Zookeeper.CApi+ , Database.Zookeeper.Types+ build-depends: base (>= 4 && < 5)+ , tasty (>= 0.3 && < 1)+ , bytestring (>= 0.10 && < 1)+ , tasty-hunit (>= 0.2 && < 1)+ hs-source-dirs: src+ extra-libraries: zookeeper_mt+ default-language: Haskell2010+ other-extensions: OverloadedStrings+ default-extensions: ForeignFunctionInterface
+ src/Database/Zookeeper.hs view
@@ -0,0 +1,423 @@+-- This file is part of zhk+--+-- 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.+-- +-- Neither the name of the {organization} nor the names of its+-- contributors may be used to endorse or promote products derived from+-- this software without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 HOLDER OR CONTRIBUTORS 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.++-- | Zookeeper client library+module Database.Zookeeper+ ( -- * Description+ -- $description++ -- * Example+ -- $example++ -- * Notes+ -- $notes++ -- * Connection+ addAuth+ , setWatcher+ , withZookeeper++ -- * Configuration/State+ , getState+ , getClientId+ , setDebugLevel+ , getRecvTimeout++ -- * Reading+ , get+ , exists+ , getAcl+ , getChildren++ -- * Writing+ , set+ , create+ , delete+ , setAcl++ -- * Types+ , Scheme+ , Timeout+ , Watcher+ , ClientID (..)+ , Zookeeper ()++ , Acl (..)+ , Perm (..)+ , Stat (..)+ , Event (..)+ , State (..)+ , AclList (..)+ , Version+ , ZLogLevel (..)+ , CreateFlag (..)++ -- ** Error values+ , ZKError (..)+ ) where++import Foreign+import Foreign.C+import Control.Monad+import qualified Data.ByteString as B+import Control.Exception+import Database.Zookeeper.CApi+import Database.Zookeeper.Types++-- | Connects to the zookeeper cluster. This function may throw an+-- exception if a valid zookeeper handle could not be created.+--+-- The connection is terminated right before this function returns.+withZookeeper :: String+ -- ^ The zookeeper endpoint to connect to. This is given+ -- as-is to the underlying C API. Briefly, host:port+ -- separated by comma. At the end, you may define an+ -- optional chroot, like the following:+ -- localhost:2181,localhost:2182/foobar+ -> Timeout+ -- ^ The session timeout (milliseconds)+ -> Maybe Watcher+ -- ^ The global watcher function. When notifications are+ -- triggered this function will be invoked+ -> Maybe ClientID+ -- ^ The id of a previously established session that+ -- this client will be reconnecting to+ -> (Zookeeper -> IO a)+ -- ^ The main loop. The session is terminated when this+ -- function exists (successfully or not)+ -> IO a+withZookeeper endpoint timeout watcher clientId io = do+ withCString endpoint $ \strPtr -> mask $ \restore -> do+ cWatcher <- wrapWatcher watcher+ zh <- throwIfNull "zookeeper_init" $ c_zookeeperInit strPtr cWatcher (fromIntegral timeout) cClientIdPtr nullPtr 0+ value <- (restore $ io (Zookeeper zh)) `onException` c_zookeeperClose zh+ c_zookeeperClose zh+ return value+ where+ cClientIdPtr = case clientId of+ Nothing -> nullPtr+ Just (ClientID ptr) -> ptr++-- | Sets [or redefines] the watcher function+setWatcher :: Zookeeper+ -- ^ Zookeeper handle+ -> Watcher+ -- ^ New watch function to register+ -> IO ()+setWatcher (Zookeeper zptr) watcher = c_zooSetWatcher zptr =<< wrapWatcher (Just watcher)++-- | The current state of this session+getState :: Zookeeper+ -- ^ Zookeeper handle+ -> IO State+ -- ^ Current state+getState (Zookeeper zh) = fmap toState $ c_zooState zh++-- | The client session id, only valid if the session currently+-- connected [ConnectedState]+getClientId :: Zookeeper -> IO ClientID+getClientId (Zookeeper zh) = fmap ClientID $ c_zooClientId zh++-- | The timeout for this session, only valid if the session is+-- currently connected [ConnectedState]+getRecvTimeout :: Zookeeper -> IO Int+getRecvTimeout (Zookeeper zh) = fmap fromIntegral $ c_zooRecvTimeout zh++-- | Sets the debugging level for the c-library+setDebugLevel :: ZLogLevel -> IO ()+setDebugLevel = c_zooSetDebugLevel . fromLogLevel++-- | Creates a znode (asynchornous)+create :: Zookeeper+ -- ^ Zookeeper handle+ -> String+ -- ^ The name of the znode expressed as a file name with slashes+ -- separating ancestors of the znode+ -> Maybe B.ByteString+ -- ^ The data to be stored in the znode+ -> AclList+ -- ^ The initial ACL of the node. The ACL must not be empty+ -> [CreateFlag]+ -- ^ Optional, may be empty+ -> (Either ZKError String -> IO ())+ -- ^ The callback function. On error the user may observe the+ -- following values:+ --+ -- * Left NoNodeError -> the parent znode does not exit+ --+ -- * Left NodeExistsError -> the node already exists+ --+ -- * Left NoAuthError -> client does not have permission+ --+ -- * Left NoChildrenForEphemeralsError -> cannot create children of ephemeral nodes+ --+ -- * Left BadArgumentsError -> invalid input params+ --+ -- * Left InvalidStateError -> Zookeeper state is either `ExpiredSessionState' or `AuthFailedState'+ -> IO ()+create (Zookeeper zh) path mvalue acls flags callback =+ withCString path $ \pathPtr ->+ maybeUseAsCStringLen mvalue $ \(valuePtr, valueLen) ->+ withAclList acls $ \aclPtr -> do+ cStrFn <- wrapStringCompletion callback+ rc <- c_zooACreate zh pathPtr valuePtr (fromIntegral valueLen) aclPtr (fromCreateFlags flags) cStrFn nullPtr+ when (not $ isZOK rc) (callback $ Left (toZKError rc))+ where+ maybeUseAsCStringLen Nothing f = f (nullPtr, -1)+ maybeUseAsCStringLen (Just s) f = B.useAsCStringLen s f++-- | Delete a znode in zookeeper+delete :: Zookeeper+ -- ^ Zookeeper handle+ -> String+ -- ^ The name of the znode expressed as a file name with slashes+ -- separating ancestors of the znode+ -> Maybe Version+ -- ^ The expected version of the znode. The function will fail+ -- if the actual version of the znode does not match the+ -- expected version. If `Nothing' is given the version check+ -- will not take place+ -> IO (Either ZKError ())+ -- ^ If an error occurs, you may observe the following values:+ -- * Left NoNodeError -> znode does not exist+ --+ -- * Left NoAuthError -> client does not have permission+ --+ -- * Left BadVersionError -> expected version does not match actual version+ --+ -- * Left BadArgumentsError -> invalid input parameters+ --+ -- * Left InvalidStateError -> Zookeeper state is either `ExpiredSessionState' or `AuthFailedState'+delete (Zookeeper zh) path mversion =+ withCString path $ \pathPtr ->+ tryZ (c_zooDelete zh pathPtr (maybe (-1) fromIntegral mversion)) (return ())++-- ^ Checks the existence of a znode+exists :: Zookeeper+ -- ^ Zookeeper handle+ -> String+ -- ^ The name of the znode expressed as a file name with slashes+ -- separating ancestors of the znode+ -> Maybe Watcher+ -- ^ This is set even if the znode does not exist. This allows+ -- users to watch znodes to appear+ -> IO (Either ZKError Stat)+ -- ^ If an error occurs, you may observe the following values:+ -- * Left NoNodeError -> znode does not exist+ --+ -- * Left NoAuthError -> client does not have permission+ --+ -- * Left BadArgumentsError -> invalid input parameters+ --+ -- * Left InvalidStateError -> Zookeeper state is either `ExpiredSessionState' or `AuthFailedState'+exists (Zookeeper zh) path mwatcher =+ withCString path $ \pathPtr ->+ allocaStat $ \statPtr -> do+ cWatcher <- wrapWatcher mwatcher+ tryZ (c_zooWExists zh pathPtr cWatcher nullPtr statPtr) (toStat statPtr)++-- | Lists the children of a znode (asynchronous)+getChildren :: Zookeeper+ -- ^ Zookeeper handle+ -> String+ -- ^ The name of the znode expressed as a file name with slashes+ -- separating ancestors of the znode+ -> Maybe Watcher+ -- ^ The watch to be set at the server to notify the user+ -- if the node changes+ -> (Either ZKError [String] -> IO ())+ -- ^ The callback function+ -> IO ()+getChildren (Zookeeper zh) path mwatcher callback = do+ withCString path (\pathPtr -> do+ cWatcher <- wrapWatcher mwatcher+ cStrFn <- wrapStringsCompletion callback+ rc <- c_zooAWGetChildren zh pathPtr cWatcher nullPtr cStrFn nullPtr+ when (not $ isZOK rc) (callback $ Left (toZKError rc)))++-- | Gets the data associated with a znode+get :: Zookeeper+ -- ^ The Zookeeper handle+ -> String+ -- ^ The name of the znode expressed as a file name with slashes+ -- separating ancestors of the znode+ -> Maybe Watcher+ -- ^ When provided, a watch will be set at the server to notify+ -- the client if the node changes+ -> (Either ZKError (Maybe B.ByteString, Stat) -> IO ())+ -- ^ The callback function+ -> IO ()+get (Zookeeper zh) path mwatcher callback =+ withCString path $ \pathPtr -> do+ cWatcher <- wrapWatcher mwatcher+ cDataFn <- wrapDataCompletion callback+ rc <- c_zooAWGet zh pathPtr cWatcher nullPtr cDataFn nullPtr+ when (not $ isZOK rc) (callback $ Left (toZKError rc))++-- | Sets the data associated with a znode+set :: Zookeeper+ -- ^ Zookeeper handle+ -> String+ -- ^ The name of the znode expressed as a file name with slashes+ -- separating ancestors of the znode+ -> Maybe B.ByteString+ -- ^ The data to set on this znode+ -> Maybe Version+ -- ^ The expected version of the znode. The function will fail+ -- if the actual version of the znode does not match the+ -- expected version. If `Nothing' is given the version check+ -- will not take place+ -> IO (Either ZKError Stat)+set (Zookeeper zh) path mdata version =+ withCString path $ \pathPtr ->+ allocaStat $ \statPtr -> do+ maybeUseAsCStringLen mdata $ \(dataPtr, dataLen) -> do+ rc <- c_zooSet2 zh pathPtr dataPtr (fromIntegral dataLen) (maybe (-1) fromIntegral version) statPtr+ onZOK rc (toStat statPtr)+ where+ maybeUseAsCStringLen Nothing f = f (nullPtr, -1)+ maybeUseAsCStringLen (Just s) f = B.useAsCStringLen s f++-- | Sets the acl associated with a node. This operation is not+-- recursive on the children. See 'getAcl' for more information.+setAcl :: Zookeeper+ -- ^ Zookeeper handle+ -> String+ -- ^ The name of the znode expressed as a file name with slashes+ -- separating ancestors of the znode+ -> Maybe Version+ -- ^ The expected version of the znode. The function will fail+ -- if the actual version of the znode does not match the+ -- expected version. If `Nothing' is given the version check+ -- will not take place+ -> AclList+ -- ^ The ACL list to be set on the znode. The ACL must not be empty+ -> IO (Either ZKError ())+setAcl (Zookeeper zh) path version acls =+ withCString path $ \pathPtr ->+ withAclList acls $ \aclPtr -> do+ rc <- c_zooSetAcl zh pathPtr (maybe (-1) fromIntegral version) aclPtr+ onZOK rc $ return ()++-- | Gets the acl associated with a node. Unexpectedly, 'setAcl' and+-- 'getAcl' are not symmetric:+--+-- > setAcl zh path Nothing OpenAclUnsafe+-- > getAcl zh path (..) -- yields AclList instead of OpenAclUnsafe+getAcl :: Zookeeper+ -- ^ The zookeeper handle+ -> String+ -- ^ The name of the znode expressed as a file name with slashes+ -- separating ancestors of the znode+ -> (Either ZKError (AclList, Stat) -> IO ())+ -- ^ The callback function+ -> IO ()+getAcl (Zookeeper zh) path callback =+ withCString path $ \pathPtr -> do+ cAclFn <- wrapAclCompletion callback+ rc <- c_zooAGetAcl zh pathPtr cAclFn nullPtr+ when (not $ isZOK rc) (callback $ Left (toZKError rc))++-- | Specify application credentials+--+-- The application calls this function to specify its credentials for+-- purposes of authentication. The server will use the security+-- provider specified by the scheme parameter to authenticate the+-- client connection. If the authentication request has failed:+--+-- * the server connection is dropped;+--+-- * the watcher is called witht AuthFailedState value as the state+-- parameter;+addAuth :: Zookeeper+ -- ^ Zookeeper handle+ -> Scheme+ -- ^ Scheme id of the authentication scheme. Natively supported:+ --+ -- * "digest" -> password authentication;+ --+ -- * "ip" -> client's IP address;+ --+ -- * "host" -> client's hostname;+ -> B.ByteString+ -- ^ Applicaton credentials. The actual value depends on the scheme+ -> (Either ZKError () -> IO ())+ -- ^ The callback function+ -> IO ()+addAuth (Zookeeper zh) scheme cert callback =+ withCString scheme $ \schemePtr ->+ B.useAsCStringLen cert $ \(certPtr, certLen) -> do+ cVoidFn <- wrapVoidCompletion callback+ rc <- c_zooAddAuth zh schemePtr certPtr (fromIntegral certLen) cVoidFn nullPtr+ when (not $ isZOK rc) (callback $ Left (toZKError rc))++-- $description+--+-- This library provides haskell bindings for zookeeper c-library. The+-- underlying library exposes two classes of functions: synchronous+-- and asynchronous. Whenever possible the synchronous functions are+-- used.+--+-- The reason we do not always use the synchronous version is that it+-- requires the caller to allocate memory and currently it is+-- impossible to know (at least I could not figure it) how much memory+-- should be allocated. The asynchronous version has no such problem+-- as it manages memory internally.++-- $example+--+-- The following snippet lists all children of the root znode:+-- +-- > module Main where+-- >+-- > import Database.Zookeeper+-- > import Control.Concurrent+-- >+-- > main :: IO ()+-- > main = do+-- > mvar <- newEmptyMVar+-- > withZookeeper "localhost:2181" 1000 (Just $ watcher mvar) Nothing $ \_ -> do+-- > takeMVar mvar >>= print+-- > where+-- > watcher mvar zh _ ConnectedState _ =+-- > create zh "/foobar" Nothing OpenAclUnsafe [] $ \_ ->+-- > getChildren zh "/" Nothing (putMVar mvar)++-- $notes+-- * Watcher callbacks must never block;+--+-- * Make sure you link against zookeeper_mt;+--+-- * Make sure you are using the `threaded' (GHC) runtime;+-- +-- * The connection is closed right before the 'withZookeeper'+-- terminates;+--+-- * There is no yet support for multi operations (executing a+-- series of operations atomically);
+ src/Database/Zookeeper/CApi.hsc view
@@ -0,0 +1,376 @@+{-# LANGUAGE ForeignFunctionInterface #-}++-- This file is part of zhk+--+-- 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.+-- +-- Neither the name of the {organization} nor the names of its+-- contributors may be used to endorse or promote products derived from+-- this software without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 HOLDER OR CONTRIBUTORS 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.++module Database.Zookeeper.CApi+ ( -- * C to Haskell+ toStat+ , toState+ , toZKError+ , allocaStat+ -- * Haskell to C+ , withAclList+ , wrapWatcher+ , fromLogLevel+ , fromCreateFlag+ , fromCreateFlags+ , wrapAclCompletion+ , wrapDataCompletion+ , wrapVoidCompletion+ , wrapStringCompletion+ , wrapStringsCompletion+ -- * Error handling+ , tryZ+ , isZOK+ , onZOK+ , whenZOK+ -- * C functions+ , c_zooSet2+ , c_zooAWGet+ , c_zooState+ , c_zooDelete+ , c_zooSetAcl+ , c_zooAGetAcl+ , c_zooACreate+ , c_zooAddAuth+ , c_zooWExists+ , c_zooClientId+ , c_zookeeperInit+ , c_zookeeperClose+ , c_zooSetWatcher+ , c_zooRecvTimeout+ , c_isUnrecoverable+ , c_zooAWGetChildren+ , c_zooSetDebugLevel+ ) where++#include <zookeeper.h>++import Foreign+import Foreign.C+import qualified Data.ByteString as B+import Control.Applicative+import Database.Zookeeper.Types++tryZ :: IO CInt -> IO a -> IO (Either ZKError a)+tryZ zkIO nextIO = do+ rc <- zkIO+ rc `onZOK` nextIO++isZOK :: CInt -> Bool+isZOK rc = rc == (#const ZOK)++onZOK :: CInt -> IO a -> IO (Either ZKError a)+onZOK rc nextIO+ | isZOK rc = fmap Right nextIO+ | otherwise = return (Left $ toZKError rc)++whenZOK :: CInt -> IO (Either ZKError a) -> IO (Either ZKError a)+whenZOK rc succIO+ | isZOK rc = succIO+ | otherwise = return (Left $ toZKError rc)++toStat :: Ptr CStat -> IO Stat+toStat ptr = Stat <$> (#peek struct Stat, czxid) ptr+ <*> (#peek struct Stat, mzxid) ptr+ <*> (#peek struct Stat, pzxid) ptr+ <*> (#peek struct Stat, ctime) ptr+ <*> (#peek struct Stat, mtime) ptr+ <*> (#peek struct Stat, version) ptr+ <*> (#peek struct Stat, cversion) ptr+ <*> (#peek struct Stat, aversion) ptr+ <*> (#peek struct Stat, dataLength) ptr+ <*> (#peek struct Stat, numChildren) ptr+ <*> liftA toEphemeralOwner ((#peek struct Stat, ephemeralOwner) ptr)+ where+ toEphemeralOwner 0 = Nothing+ toEphemeralOwner c = Just c++fromCreateFlag :: CreateFlag -> CInt+fromCreateFlag Sequence = (#const ZOO_SEQUENCE)+fromCreateFlag Ephemeral = (#const ZOO_EPHEMERAL)++fromCreateFlags :: [CreateFlag] -> CInt+fromCreateFlags = foldr (.|.) 0 . map fromCreateFlag++fromPerm :: Perm -> CInt+fromPerm CanRead = (#const ZOO_PERM_READ)+fromPerm CanAdmin = (#const ZOO_PERM_ADMIN)+fromPerm CanWrite = (#const ZOO_PERM_WRITE)+fromPerm CanCreate = (#const ZOO_PERM_CREATE)+fromPerm CanDelete = (#const ZOO_PERM_DELETE)++fromLogLevel :: ZLogLevel -> CInt+fromLogLevel ZLogError = (#const ZOO_LOG_LEVEL_ERROR)+fromLogLevel ZLogWarn = (#const ZOO_LOG_LEVEL_WARN)+fromLogLevel ZLogInfo = (#const ZOO_LOG_LEVEL_INFO)+fromLogLevel ZLogDebug = (#const ZOO_LOG_LEVEL_DEBUG)++fromPerms :: [Perm] -> CInt+fromPerms = foldr (.|.) 0 . map fromPerm++toPerms :: CInt -> [Perm]+toPerms n = buildList [ ((#const ZOO_PERM_READ), CanRead)+ , ((#const ZOO_PERM_ADMIN), CanAdmin)+ , ((#const ZOO_PERM_WRITE), CanWrite)+ , ((#const ZOO_PERM_CREATE), CanCreate)+ , ((#const ZOO_PERM_DELETE), CanDelete)+ ]+ where+ buildList [] = []+ buildList ((t, a):xs)+ | n .&. t == t = a : buildList xs+ | otherwise = buildList xs++toStringList :: Ptr CStrVec -> IO [String]+toStringList strvPtr = do+ count <- (#peek struct String_vector, count) strvPtr+ dataPtr <- (#peek struct String_vector, data) strvPtr+ buildList [] count dataPtr+ where+ buildList :: [String] -> Int32 -> Ptr CString -> IO [String]+ buildList acc 0 _ = return $ reverse acc+ buildList acc n ptr = do+ item <- peek ptr >>= peekCString+ buildList (item : acc) (n-1) (ptr `plusPtr` (sizeOf ptr))++allocaStat :: (Ptr CStat -> IO a) -> IO a+allocaStat fun = allocaBytes (#size struct Stat) fun++toAclList :: Ptr CAclVec -> IO AclList+toAclList aclvPtr = do+ count <- (#peek struct ACL_vector, count) aclvPtr+ aclPtr <- (#peek struct ACL_vector, data) aclvPtr+ fmap List (buildList [] count aclPtr)+ where+ buildList :: [Acl] -> Int32 -> Ptr CAcl -> IO [Acl]+ buildList acc 0 _ = return acc+ buildList acc n ptr = do+ acl <- Acl <$> ((#peek struct ACL, id.scheme) ptr >>= peekCString)+ <*> ((#peek struct ACL, id.id) ptr >>= peekCString)+ <*> (fmap toPerms ((#peek struct ACL, perms) ptr))+ buildList (acl : acc) (n-1) (ptr `plusPtr` (#size struct ACL))++withAclList :: AclList -> (Ptr CAclVec -> IO a) -> IO a+withAclList CreatorAll cont = cont c_zooCreatorAclAll+withAclList OpenAclUnsafe cont = cont c_zooOpenAclUnsafe+withAclList ReadAclUnsafe cont = cont c_zooReadAclUnsafe+withAclList (List acls) cont =+ allocaBytes (#size struct ACL_vector) $ \aclvPtr -> do+ (#poke struct ACL_vector, count) aclvPtr count+ allocaBytes (count * (#size struct ACL)) $ \aclPtr -> do+ (#poke struct ACL_vector, data) aclvPtr aclPtr+ pokeAcls acls aclvPtr aclPtr+ where+ count = length acls++ pokeAcls [] aclvPtr _ = cont aclvPtr+ pokeAcls (acl:rest) aclvPtr aclPtr = do+ withCString (aclScheme acl) $ \schemePtr -> do+ withCString (aclId acl) $ \idPtr -> do+ (#poke struct ACL, id.id) aclPtr idPtr+ (#poke struct ACL, perms) aclPtr (fromPerms (aclFlags acl))+ (#poke struct ACL, id.scheme) aclPtr schemePtr+ pokeAcls rest aclvPtr (aclPtr `plusPtr` (#size struct ACL))++toZKError :: CInt -> ZKError+toZKError (#const ZNONODE) = NoNodeError+toZKError (#const ZNOAUTH) = NoAuthError+toZKError (#const ZCLOSING) = ClosingError+toZKError (#const ZNOTHING) = NothingError+toZKError (#const ZAPIERROR) = ApiError+toZKError (#const ZNOTEMPTY) = NotEmptyError+toZKError (#const ZBADVERSION) = BadVersionError+toZKError (#const ZINVALIDACL) = InvalidACLError+toZKError (#const ZAUTHFAILED) = AuthFailedError+toZKError (#const ZNODEEXISTS) = NodeExistsError+toZKError (#const ZSYSTEMERROR) = SystemError+toZKError (#const ZBADARGUMENTS) = BadArgumentsError+toZKError (#const ZINVALIDSTATE) = InvalidStateError+toZKError (#const ZSESSIONMOVED) = SessionMovedError+toZKError (#const ZUNIMPLEMENTED) = UnimplmenetedError+toZKError (#const ZCONNECTIONLOSS) = ConnectionLossError+toZKError (#const ZSESSIONEXPIRED) = SessionExpiredError+toZKError (#const ZINVALIDCALLBACK) = InvalidCallbackError+toZKError (#const ZMARSHALLINGERROR) = MarshallingError+toZKError (#const ZOPERATIONTIMEOUT) = OperationTimeoutError+toZKError (#const ZDATAINCONSISTENCY) = DataInconsistencyError+toZKError (#const ZRUNTIMEINCONSISTENCY) = RuntimeInconsistencyError+toZKError (#const ZNOCHILDRENFOREPHEMERALS) = NoChildrenForEphemeralsError+toZKError code = (UnknownError $ fromIntegral code)++toState :: CInt -> State+toState (#const ZOO_CONNECTED_STATE) = ConnectedState+toState (#const ZOO_CONNECTING_STATE) = ConnectingState+toState (#const ZOO_ASSOCIATING_STATE) = AssociatingState+toState (#const ZOO_AUTH_FAILED_STATE) = AuthFailedState+toState (#const ZOO_EXPIRED_SESSION_STATE) = ExpiredSessionState+toState code = UnknownState $ fromIntegral code++toEvent :: CInt -> Event+toEvent (#const ZOO_CHILD_EVENT) = ChildEvent+toEvent (#const ZOO_CREATED_EVENT) = CreatedEvent+toEvent (#const ZOO_DELETED_EVENT) = DeletedEvent+toEvent (#const ZOO_CHANGED_EVENT) = ChangedEvent+toEvent (#const ZOO_SESSION_EVENT) = SessionEvent+toEvent (#const ZOO_NOTWATCHING_EVENT) = NotWatchingEvent+toEvent code = UnknownEvent $ fromIntegral code++wrapWatcher :: Maybe Watcher -> IO (FunPtr CWatcherFn)+wrapWatcher Nothing = return nullFunPtr+wrapWatcher (Just fn) = c_watcherFn $ \zh cevent cstate cpath _ -> do+ let event = toEvent cevent+ state = toState cstate+ path <- if (cpath == nullPtr)+ then return Nothing+ else fmap Just (peekCString cpath)+ fn (Zookeeper zh) event state path++wrapAclCompletion :: AclCompletion -> IO (FunPtr CAclCompletionFn)+wrapAclCompletion fn =+ c_aclCompletionFn $ \rc aclPtr statPtr _ ->+ fn =<< (onZOK rc $ do+ aclList <- toAclList aclPtr+ stat <- toStat statPtr+ return (aclList, stat))++wrapDataCompletion :: DataCompletion -> IO (FunPtr CDataCompletionFn)+wrapDataCompletion fn =+ c_dataCompletionFn $ \rc valPtr valLen statPtr _ ->+ fn =<< (onZOK rc $ do+ stat <- toStat statPtr+ if (valLen == -1)+ then return (Nothing, stat)+ else fmap (\s -> (Just s, stat)) (B.packCStringLen (valPtr, fromIntegral valLen)))++wrapStringCompletion :: StringCompletion -> IO (FunPtr CStringCompletionFn)+wrapStringCompletion fn =+ c_stringCompletionFn $ \rc strPtr _ ->+ fn =<< (onZOK rc $ do+ peekCString strPtr)++wrapStringsCompletion :: StringsCompletion -> IO (FunPtr CStringsCompletionFn)+wrapStringsCompletion fn =+ c_stringsCompletionFn $ \rc strvPtr _ ->+ fn =<< (onZOK rc (toStringList strvPtr))++wrapVoidCompletion :: VoidCompletion -> IO (FunPtr CVoidCompletionFn)+wrapVoidCompletion fn =+ c_voidCompletionFn $ \rc _ -> (fn =<< onZOK rc (return ()))++foreign import ccall safe "wrapper"+ c_watcherFn :: CWatcherFn+ -> IO (FunPtr CWatcherFn)++foreign import ccall safe "wrapper"+ c_dataCompletionFn :: CDataCompletionFn+ -> IO (FunPtr CDataCompletionFn)++foreign import ccall safe "wrapper"+ c_stringsCompletionFn :: CStringsCompletionFn+ -> IO (FunPtr CStringsCompletionFn)++foreign import ccall safe "wrapper"+ c_stringCompletionFn :: CStringCompletionFn+ -> IO (FunPtr CStringCompletionFn)++foreign import ccall safe "wrapper"+ c_aclCompletionFn :: CAclCompletionFn+ -> IO (FunPtr CAclCompletionFn)++foreign import ccall safe "wrapper"+ c_voidCompletionFn :: CVoidCompletionFn+ -> IO (FunPtr CVoidCompletionFn)++foreign import ccall safe "zookeeper.h zookeeper_init"+ c_zookeeperInit :: CString+ -> FunPtr CWatcherFn+ -> CInt+ -> Ptr CClientID+ -> Ptr ()+ -> CInt+ -> IO (Ptr CZHandle)++foreign import ccall safe "zookeeper.h zookeeper_close"+ c_zookeeperClose :: Ptr CZHandle -> IO ()++foreign import ccall safe "zookeeper.h zoo_set_watcher"+ c_zooSetWatcher :: Ptr CZHandle -> FunPtr CWatcherFn -> IO ()++foreign import ccall safe "zookeeper.h zoo_acreate"+ c_zooACreate :: Ptr CZHandle -> CString -> CString -> CInt -> Ptr CAclVec -> CInt -> FunPtr CStringCompletionFn -> Ptr () -> IO CInt++foreign import ccall safe "zookeeper.h zoo_delete"+ c_zooDelete :: Ptr CZHandle -> CString -> CInt -> IO CInt++foreign import ccall safe "zookeeper.h zoo_wexists"+ c_zooWExists :: Ptr CZHandle -> CString -> FunPtr CWatcherFn -> Ptr () -> Ptr CStat -> IO CInt++foreign import ccall safe "zookeeper.h zoo_state"+ c_zooState :: Ptr CZHandle -> IO CInt++foreign import ccall safe "zookeeper.h zoo_client_id"+ c_zooClientId :: Ptr CZHandle -> IO (Ptr CClientID)++foreign import ccall safe "zookeeper.h zoo_recv_timeout"+ c_zooRecvTimeout :: Ptr CZHandle -> IO CInt++foreign import ccall safe "zookeeper.h zoo_add_auth"+ c_zooAddAuth :: Ptr CZHandle -> CString -> CString -> CInt -> FunPtr CVoidCompletionFn -> Ptr () -> IO CInt++foreign import ccall safe "zookeeper.h is_unrecoverable"+ c_isUnrecoverable :: Ptr CZHandle -> IO CInt++foreign import ccall safe "zookeeper.h zoo_set_debug_level"+ c_zooSetDebugLevel :: CInt -> IO ()++foreign import ccall safe "zookeeper.h zoo_aget_acl"+ c_zooAGetAcl :: Ptr CZHandle -> CString -> FunPtr CAclCompletionFn -> Ptr () -> IO CInt++foreign import ccall safe "zookeeper.h zoo_set_acl"+ c_zooSetAcl :: Ptr CZHandle -> CString -> CInt -> Ptr CAclVec -> IO CInt++foreign import ccall safe "zookeeper.h zoo_awget"+ c_zooAWGet :: Ptr CZHandle -> CString -> FunPtr CWatcherFn -> Ptr () -> FunPtr CDataCompletionFn -> Ptr () -> IO CInt++foreign import ccall safe "zookeeper.h zoo_set2"+ c_zooSet2 :: Ptr CZHandle -> CString -> CString -> CInt -> CInt -> Ptr CStat -> IO CInt++foreign import ccall safe "zookeeper.h zoo_awget_children"+ c_zooAWGetChildren :: Ptr CZHandle -> CString -> FunPtr CWatcherFn -> Ptr () -> FunPtr CStringsCompletionFn -> Ptr () -> IO CInt++foreign import ccall safe "zookeeper.h &ZOO_CREATOR_ALL_ACL"+ c_zooCreatorAclAll :: Ptr CAclVec++foreign import ccall safe "zookeeper.h &ZOO_OPEN_ACL_UNSAFE"+ c_zooOpenAclUnsafe :: Ptr CAclVec++foreign import ccall safe "zookeeper.h &ZOO_READ_ACL_UNSAFE"+ c_zooReadAclUnsafe :: Ptr CAclVec
+ src/Database/Zookeeper/Types.hs view
@@ -0,0 +1,275 @@+-- This file is part of zhk+--+-- 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.+-- +-- Neither the name of the {organization} nor the names of its+-- contributors may be used to endorse or promote products derived from+-- this software without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 HOLDER OR CONTRIBUTORS 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.++module Database.Zookeeper.Types+ ( -- * Public Types+ Acl (..)+ , Perm (..)+ , Stat (..)+ , Event (..)+ , State (..)+ , Scheme+ , AclList (..)+ , Timeout+ , Version+ , ClientID (..)+ , ZLogLevel (..)+ , Zookeeper (..)+ , CreateFlag (..)+ -- * Error codes+ , ZKError (..)+ -- * Public Callbacks+ , Watcher+ , AclCompletion+ , DataCompletion+ , VoidCompletion+ , StringCompletion+ , StringsCompletion+ -- * Low-level Types+ , CAcl+ , CStat+ , CAclVec+ , CStrVec+ , CZHandle+ , CClientID+ -- * Low-level Callbacks+ , CWatcherFn+ , CAclCompletionFn+ , CVoidCompletionFn+ , CDataCompletionFn+ , CStringCompletionFn+ , CStringsCompletionFn+ ) where++import Foreign+import Foreign.C+import qualified Data.ByteString as B++-- | Zookeeper connection handler+newtype Zookeeper = Zookeeper (Ptr CZHandle)++-- | The current clientid that may be used to reconnect+newtype ClientID = ClientID (Ptr CClientID)++-- | Timeout in milliseconds+type Timeout = Int++type Version = Int++-- | Authentication scheme provider+type Scheme = String++data ZLogLevel = ZLogError+ | ZLogWarn+ | ZLogInfo+ | ZLogDebug++-- | Zookeeper error codes+data ZKError = ApiError+ | NoAuthError+ | NoNodeError+ | SystemError+ | ClosingError+ | NothingError+ | NotEmptyError+ | AuthFailedError+ | BadVersionError+ | InvalidACLError+ | NodeExistsError+ | MarshallingError+ | BadArgumentsError+ | InvalidStateError+ | SessionMovedError+ | UnimplmenetedError+ | ConnectionLossError+ | SessionExpiredError+ | InvalidCallbackError+ | OperationTimeoutError+ | DataInconsistencyError+ | RuntimeInconsistencyError+ | NoChildrenForEphemeralsError+ | UnknownError Int+ deriving (Eq, Show)++-- | The stat of a znode+data Stat = Stat { statCzxId :: Int64+ -- ^ The zxid of the change that caused this node to be created+ , statMzxId :: Int64+ -- ^ The zxid of the change that last modified this znode+ , statPzxId :: Int64+ -- ^ The zxid of the change that last modified children of this znode+ , statCreatetime :: Int64+ -- ^ The time in milliseconds from epoch when this znode was created+ , statModifytime :: Int64+ -- ^ The time in milliseconds from epoch when this znode was last modified+ , statVersion :: Int32+ -- ^ The number of changes to the data of this znode+ , statChildrenVersion :: Int32+ -- ^ The number of changes to the children of this znode+ , statAclVersion :: Int32+ -- ^ The number of changes to the acl of this znode+ , statDataLength :: Int32+ -- ^ The length of the data field of this znode+ , statNumChildren :: Int32+ -- ^ The number of children of this znode+ , statEphemeralOwner :: Maybe Int64+ -- ^ The session id of the owner of this znode if the znode is an ephemeral node+ }+ deriving (Eq, Show)++data Event = ChildEvent+ | CreatedEvent+ | DeletedEvent+ | ChangedEvent+ | SessionEvent+ | NotWatchingEvent+ | UnknownEvent Int+ -- ^ Used when the underlying C API has returned an unknown event type+ deriving (Eq, Show)++data State = ExpiredSessionState+ | AuthFailedState+ | ConnectingState+ | AssociatingState+ | ConnectedState+ | UnknownState Int+ -- ^ Used when the underlying C API has returned an unknown status code+ deriving (Eq, Show)++-- | The permission bits of a ACL+data Perm = CanRead+ -- ^ Can read data and enumerate its children+ | CanAdmin+ -- ^ Can modify permissions bits+ | CanWrite+ -- ^ Can modify data+ | CanCreate+ -- ^ Can create children+ | CanDelete+ -- ^ Can remove+ deriving (Eq, Show)++data Acl = Acl { aclScheme :: String+ -- ^ The ACL scheme (e.g. "ip", "world", "digest"+ , aclId :: String+ -- ^ The schema-depent ACL identity (e.g. scheme="ip", id="127.0.0.1")+ , aclFlags :: [Perm]+ -- ^ The [non empty] list of permissions+ }+ deriving (Eq, Show)++data AclList = List [Acl]+ -- ^ A [non empty] list of ACLs+ | CreatorAll+ -- ^ This gives the creators authentication id's all permissions+ | OpenAclUnsafe+ -- ^ This is a completely open ACL+ | ReadAclUnsafe+ -- ^ This ACL gives the world the ability to read+ deriving (Eq, Show)++-- | The optional flags you may use to create a node+data CreateFlag = Sequence+ -- ^ A unique monotonically increasing sequence number is appended to the path name+ | Ephemeral+ -- ^ The znode will automatically get removed if the client session goes away+ deriving (Eq, Show)++-- | The watcher function, which allows you to get notified about+-- zookeeper events.+type Watcher = Zookeeper+ -> Event+ -- ^ The event that has triggered the watche+ -> State+ -- ^ The connection state+ -> Maybe String+ -- ^ The znode for which the watched is triggered+ -> IO ()++-- | Callback function for `wrapDataCompletion', which you can use+-- with c_zooAWGet function. You probably don't need this.+type DataCompletion = Either ZKError (Maybe B.ByteString, Stat) -> IO ()++-- | Callback function for `wrapStringsCompletion', which you can use+-- with c_zooAWGetChildren function. You probably don't need this.+type StringsCompletion = Either ZKError [String] -> IO ()++-- | Callback function for `wrapStringCompletion', which you can use+-- with c_zooACreate function. You probably don't need this.+type StringCompletion = Either ZKError String -> IO ()++-- | Callback function for `wrapAclCompletion', which you can use with+-- c_zooAGetAcl function. You probably don't need this.+type AclCompletion = Either ZKError (AclList, Stat) -> IO ()++-- | Callback function for `wrapVoidCompletion', which you can use+-- with c_zooAddAuth function. You probably don't need this.+type VoidCompletion = Either ZKError () -> IO ()++data CAcl+data CStat+data CAclVec+data CStrVec+data CZHandle+data CClientID++type CWatcherFn = Ptr CZHandle+ -> CInt+ -> CInt+ -> CString+ -> Ptr ()+ -> IO ()++type CVoidCompletionFn = CInt+ -> Ptr ()+ -> IO ()++type CDataCompletionFn = CInt+ -> CString+ -> CInt+ -> Ptr CStat+ -> Ptr ()+ -> IO ()++type CStringsCompletionFn = CInt+ -> Ptr CStrVec+ -> Ptr ()+ -> IO ()++type CStringCompletionFn = CInt+ -> CString+ -> Ptr ()+ -> IO ()++type CAclCompletionFn = CInt+ -> Ptr CAclVec+ -> Ptr CStat+ -> Ptr ()+ -> IO ()+
+ src/test-zookeeper.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE OverloadedStrings #-}++-- This file is part of zhk+--+-- 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.+-- +-- Neither the name of the {organization} nor the names of its+-- contributors may be used to endorse or promote products derived from+-- this software without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 HOLDER OR CONTRIBUTORS 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.++module Main where++import Data.Maybe+import Test.Tasty+import System.Exit+import Control.Monad+import Test.Tasty.HUnit+import Control.Concurrent+import Database.Zookeeper+import System.Environment++envKey :: String+envKey = "_ZOOKEEPER_ENDPOINT"++chroot :: String -> String+chroot = ("/test-zookeeper" ++)++getEndpoint :: IO String+getEndpoint = do+ mendpoint <- fmap (lookup envKey) getEnvironment+ case mendpoint of+ Nothing -> return "localhost:2181"+ Just v -> return v++disclaimer :: IO ()+disclaimer = do+ endpoint <- getEndpoint+ putStrLn ("> This program depends on a zookeeper server. The current endpoint is: " ++ endpoint)+ putStrLn ("> You may override this default with the following env variable: " ++ envKey)++testExists zh = testGroup "exists"+ [ testCase "exists after create" $ do+ let path = chroot "/testExists#1"+ mvar <- newEmptyMVar+ create zh path Nothing OpenAclUnsafe [] (\_ ->+ exists zh path Nothing >>= putMVar mvar . either (const False) (const True))+ takeMVar mvar @? "== Right _"+ , testCase "exists without znode" $ do+ let path = chroot "/testExists#2"+ mvar <- newEmptyMVar+ exists zh path Nothing >>= (@?= Left NoNodeError)+ , testCase "exists(watcher) and create" $ do+ let path = chroot "/testExists#3"+ mvar <- newEmptyMVar+ exists zh path (Just $ watcher mvar) >>= (@?= Left NoNodeError)+ create zh path Nothing OpenAclUnsafe [] (const $ return ())+ takeMVar mvar >>= (@?= (CreatedEvent, Just path))+ , testCase "exists(watcher) and set" $ do+ let path = chroot "/testExists#4"+ mvar <- newEmptyMVar+ create zh path Nothing OpenAclUnsafe [] (\_ -> do+ exists zh path (Just $ watcher mvar)+ set zh path Nothing Nothing+ return ())+ takeMVar mvar >>= (@?= (ChangedEvent, Just path))+ , testCase "exists(watcher) and delete" $ do+ let path = chroot "/testExists#5"+ mvar <- newEmptyMVar+ create zh path Nothing OpenAclUnsafe [] (\_ -> do+ exists zh path (Just $ watcher mvar)+ delete zh path Nothing+ return ())+ takeMVar mvar >>= (@?= (DeletedEvent, Just path))+ ]+ where+ watcher mvar _ event _ mpath = putMVar mvar (event, mpath)++testGet zh = testGroup "get"+ [ testCase "get without znode" $ do+ let path = chroot "/testGet#1"+ mvar <- newEmptyMVar+ get zh path Nothing (putMVar mvar)+ takeMVar mvar >>= (@?= Left NoNodeError)+ , testCase "create(nodata) and get" $ do+ let path = chroot "/testGet#2"+ mvar <- newEmptyMVar+ create zh path Nothing OpenAclUnsafe [] (\_ ->+ get zh path Nothing (putMVar mvar . either (const False) (isNothing . fst)))+ takeMVar mvar @? "== Right (Nothing, _)"+ , testCase "create(data) and get" $ do+ let path = chroot "/testGet#3"+ mvar <- newEmptyMVar+ create zh path (Just "foobar") OpenAclUnsafe [] (\_ ->+ get zh path Nothing (putMVar mvar . either (const False) ((== Just "foobar") . fst)))+ takeMVar mvar @? "== Right (Just \"foobar\", _)"+ , testCase "get(watcher) and set" $ do+ let path = chroot "/testGet#4"+ mvar <- newEmptyMVar+ create zh path Nothing OpenAclUnsafe [] (\_ ->+ get zh path (Just $ watcher mvar) (\_ -> set zh path Nothing Nothing >> return ()))+ takeMVar mvar >>= (@?= (ChangedEvent, Just path))+ , testCase "get(watcher) and delete" $ do+ let path = chroot "/testGet#5"+ mvar <- newEmptyMVar+ create zh path Nothing OpenAclUnsafe [] (\_ ->+ get zh path (Just $ watcher mvar) (\_ -> delete zh path Nothing >> return ()))+ takeMVar mvar >>= (@?= (DeletedEvent, Just path))+ ]+ where+ watcher mvar _ event _ mpath = putMVar mvar (event, mpath)++testGetChildren zh = testGroup "getChildren"+ [ testCase "getChildren without znode" $ do+ let path = chroot "/testGetChildren#1"+ mvar <- newEmptyMVar+ getChildren zh path Nothing (putMVar mvar)+ takeMVar mvar >>= (@?= Left NoNodeError)+ , testCase "getChildren after create" $ do+ let path = chroot "/testGetChildren#2"+ mvar <- newEmptyMVar+ create zh path Nothing OpenAclUnsafe [] (\_ ->+ getChildren zh path Nothing (putMVar mvar))+ takeMVar mvar >>= (@?= Right [])+ , testCase "getChildren with one child" $ do+ let path = chroot "/testGetChildren#3"+ mvar <- newEmptyMVar+ create zh path Nothing OpenAclUnsafe [] (\_ ->+ create zh (path ++ "/1") Nothing OpenAclUnsafe [] (\_ ->+ getChildren zh path Nothing (putMVar mvar)))+ takeMVar mvar >>= (@?= Right ["1"])+ , testCase "getChildren(watcher) and create child" $ do+ let path = chroot "/testGetChildren#4"+ mvar <- newEmptyMVar+ create zh path Nothing OpenAclUnsafe [] (\_ ->+ getChildren zh path (Just $ watcher mvar) (\_ ->+ create zh (path ++ "/1") Nothing OpenAclUnsafe [] (const $ return ())))+ takeMVar mvar >>= (@?= (ChildEvent, Just path))+ , testCase "getChildren(watcher) and delete child" $ do+ let path = chroot "/testGetChildren#5"+ mvar <- newEmptyMVar+ create zh path Nothing OpenAclUnsafe [] (\_ ->+ create zh (path ++ "/1") Nothing OpenAclUnsafe [] (\_ ->+ getChildren zh path (Just $ watcher mvar) (\_ -> do+ delete zh (path ++ "/1") Nothing+ return ())))+ takeMVar mvar >>= (@?= (ChildEvent, Just path))+ ]+ where+ watcher mvar _ event _ mpath = putMVar mvar (event, mpath)++testGetAcl zh = testGroup "getAcl"+ [ testCase "getAcl" $ do+ let path = chroot "/testGetAcl#1"+ mvar <- newEmptyMVar+ create zh path Nothing OpenAclUnsafe [] (\_ ->+ getAcl zh path (putMVar mvar . either (const 0) (countAcls . fst)))+ takeMVar mvar >>= (@?= 1)+ , testCase "getAcl flags" $ do+ let path = chroot "/testGetAcl#2"+ flags = [ []+ , [CanRead]+ , [CanRead, CanAdmin]+ , [CanRead, CanAdmin, CanWrite]+ , [CanRead, CanAdmin, CanWrite, CanCreate]+ , [CanRead, CanAdmin, CanWrite, CanCreate, CanDelete]+ ]+ forM_ flags $ \flag -> do+ mvar <- newEmptyMVar+ create zh path Nothing (List [Acl "world" "anyone" flag]) [] (\_ -> do+ getAcl zh path (\rc -> do+ delete zh path Nothing+ putMVar mvar (either (const []) (getFlags . fst) rc)))+ takeMVar mvar >>= (@?= flag)+ ]+ where+ countAcls (List xs) = length xs+ countAcls _ = 1++ getFlags (List xs) = concatMap aclFlags xs+ getFlags _ = []++rmrf :: Zookeeper -> String -> IO ()+rmrf zh path = do+ let childPath name = path ++ "/" ++ name+ mvar <- newEmptyMVar+ getChildren zh path Nothing (putMVar mvar)+ takeMVar mvar >>= either (const $ return ()) (mapM_ (rmrf zh . childPath))+ delete zh path Nothing+ return ()++main :: IO ()+main = do+ disclaimer+ endpoint <- getEndpoint+ waitState <- newEmptyMVar+ waitCreate <- newEmptyMVar+ withZookeeper endpoint 5000 (Just $ watcher waitState) Nothing $ \zh -> do+ state <- takeMVar waitState+ case state of+ ConnectedState -> do+ rmrf zh (chroot "")+ create zh (chroot "") Nothing OpenAclUnsafe [] (putMVar waitCreate)+ takeMVar waitCreate+ defaultMain $ testGroup "Zookeeper" [ testGet zh+ , testExists zh+ , testGetAcl zh+ , testGetChildren zh+ ]+ _ -> exitFailure+ where+ watcher mvar _ _ e _ = putMVar mvar e