diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/hzk.cabal b/hzk.cabal new file mode 100644 --- /dev/null +++ b/hzk.cabal @@ -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 diff --git a/src/Database/Zookeeper.hs b/src/Database/Zookeeper.hs new file mode 100644 --- /dev/null +++ b/src/Database/Zookeeper.hs @@ -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); diff --git a/src/Database/Zookeeper/CApi.hsc b/src/Database/Zookeeper/CApi.hsc new file mode 100644 --- /dev/null +++ b/src/Database/Zookeeper/CApi.hsc @@ -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 + +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 diff --git a/src/Database/Zookeeper/Types.hs b/src/Database/Zookeeper/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Zookeeper/Types.hs @@ -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 () + diff --git a/src/test-zookeeper.hs b/src/test-zookeeper.hs new file mode 100644 --- /dev/null +++ b/src/test-zookeeper.hs @@ -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