diff --git a/Changes.md b/Changes.md --- a/Changes.md +++ b/Changes.md @@ -1,3 +1,6 @@ +* 1.1.1.0 + - Fixes for 2 connection leaks on errors. + - Bump upper bound on aeson to <1.1 * 1.1.0.0 - Adds bucket type as argument to many functions. - Bugfix for exceptions being ignored (https://github.com/markhibberd/riak-haskell-client/pull/46) diff --git a/riak.cabal b/riak.cabal --- a/riak.cabal +++ b/riak.cabal @@ -1,5 +1,5 @@ name: riak -version: 1.1.0.0 +version: 1.1.1.0 synopsis: A Haskell client for the Riak decentralized data store description: A Haskell client library for the Riak decentralized data @@ -99,7 +99,7 @@ Network.Riak.Tag build-depends: - aeson >= 0.8 && < 0.12, + aeson >= 0.8 && < 1.1, attoparsec >= 0.12.1.6 && < 0.14, base >= 3 && <5, binary, @@ -120,7 +120,7 @@ protocol-buffers >= 2.1.4 && < 2.5, pureMD5, random, - riak-protobuf == 0.21.*, + riak-protobuf == 0.22.*, semigroups >= 0.16, stm == 2.4.*, text == 1.2.*, diff --git a/src/Network/Riak/CRDT/Response.hs b/src/Network/Riak/CRDT/Response.hs --- a/src/Network/Riak/CRDT/Response.hs +++ b/src/Network/Riak/CRDT/Response.hs @@ -2,15 +2,18 @@ -- copyright: (c) 2016 Sentenai -- author: Antonio Nikishaev -- license: Apache --- +-- {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} module Network.Riak.CRDT.Response (get) where +#if __GLASGOW_HASKELL__ <= 708 import Control.Applicative ((<$>)) +import Data.Traversable +#endif import qualified Data.Sequence as Seq import qualified Data.Map as Map import Data.Foldable (toList) -import Data.Traversable import Data.Maybe import Network.Riak.Protocol.DtFetchResponse (DtFetchResponse,value,type') import Network.Riak.Protocol.DtFetchResponse.DataType (DataType(..)) @@ -53,4 +56,3 @@ typeToTag M.REGISTER = MapRegisterTag typeToTag M.FLAG = MapFlagTag typeToTag M.MAP = MapMapTag - diff --git a/src/Network/Riak/CRDT/Riak.hs b/src/Network/Riak/CRDT/Riak.hs --- a/src/Network/Riak/CRDT/Riak.hs +++ b/src/Network/Riak/CRDT/Riak.hs @@ -4,24 +4,26 @@ -- license: Apache -- -- CRDT operations -{-# LANGUAGE ScopedTypeVariables, MultiWayIf, OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Network.Riak.CRDT.Riak (counterSendUpdate, setSendUpdate, mapSendUpdate, get) where - +#if __GLASGOW_HASKELL__ <= 708 import Control.Applicative +import Data.Int +#endif import qualified Network.Riak.CRDT.Types as CRDT import qualified Network.Riak.Connection as Conn import Network.Riak.Types import qualified Network.Riak.Protocol.ErrorResponse as ER -import Data.Int -import Control.Applicative -import Control.Exception (catchJust) +import Control.Exception (catchJust) import qualified Data.ByteString.Lazy as BS - import qualified Network.Riak.CRDT.Request as Req import qualified Network.Riak.CRDT.Response as Resp @@ -47,7 +49,7 @@ -- | Ignore a ‘not_present’ error on update. --- +-- -- This is a bit hacky, but that's the behaviour we want. -- -- TODO: Add custom exceptions to riak-haskell-client and just catch a @@ -61,4 +63,3 @@ ) act pure - diff --git a/src/Network/Riak/Cluster.hs b/src/Network/Riak/Cluster.hs --- a/src/Network/Riak/Cluster.hs +++ b/src/Network/Riak/Cluster.hs @@ -68,10 +68,8 @@ go pools' [] where go [] errors = throwM (InClusterError errors) - go (p:ps) es = Riak.withConnectionM p $ \c -> do - er <- tryAny (f c) - either (\err -> go ps (err:es)) - return er + go (p:ps) es = + catchAny (Riak.withConnectionM p f) (\e -> go ps (e:es)) rotateL :: Int -> [a] -> [a] rotateL i xs = right ++ left diff --git a/src/Network/Riak/Connection/Internal.hs b/src/Network/Riak/Connection/Internal.hs --- a/src/Network/Riak/Connection/Internal.hs +++ b/src/Network/Riak/Connection/Internal.hs @@ -40,7 +40,7 @@ import Control.Concurrent (forkIO) import Control.Concurrent.Chan (newChan, readChan, writeChan) import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) -import Control.Exception (Exception, IOException, throwIO) +import Control.Exception (Exception, IOException, throwIO, bracketOnError) import Control.Monad (forM_, replicateM, replicateM_) import Data.Binary.Put (Put, putWord32be, runPut) import Data.IORef (newIORef, readIORef, writeIORef) @@ -108,13 +108,16 @@ (a:_) -> a _ -> moduleError "connect" $ "could not look up server " ++ host ++ ":" ++ port - onIOException "connect" $ do - sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai) - Socket.connect sock (addrAddress ai) - buf <- newIORef L.empty - let conn = Connection sock client buf - setClientID conn clientID - return conn + onIOException "connect" $ + bracketOnError + (socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai)) + sClose $ + \sock -> do + Socket.connect sock (addrAddress ai) + buf <- newIORef L.empty + let conn = Connection sock client buf + setClientID conn clientID + return conn -- | Disconnect from a server. disconnect :: Connection -> IO () @@ -204,7 +207,7 @@ throwError = throwIO getResponse :: Response a => Connection -> Int64 -> a -> T.MessageTag -> IO a -getResponse conn len v expected = do +getResponse conn len _ expected = do tag <- recvGet conn getTag case undefined of _| tag == expected -> recvGetN conn (len-1) messageGetM diff --git a/src/Network/Riak/Search.hs b/src/Network/Riak/Search.hs --- a/src/Network/Riak/Search.hs +++ b/src/Network/Riak/Search.hs @@ -2,18 +2,20 @@ -- copyright: (c) 2016 Sentenai -- author: Antonio Nikishaev -- license: Apache --- +-- -- Solr search --- +-- -- http://docs.basho.com/riak/2.1.3/dev/using/search/ - +{-# LANGUAGE CPP #-} module Network.Riak.Search where -import Network.Riak.Connection.Internal -import Network.Riak.Types.Internal +#if __GLASGOW_HASKELL__ <= 708 +import Control.Applicative +#endif +import Network.Riak.Connection.Internal import qualified Network.Riak.Request as Req import qualified Network.Riak.Response as Resp -import Control.Applicative +import Network.Riak.Types.Internal -- | Get an index info for @Just index@, or get all indexes for -- @Nothing@. @@ -25,4 +27,3 @@ -- index. searchRaw :: Connection -> SearchQuery -> Index -> IO [SearchResult] searchRaw conn q ix = Resp.search <$> exchange conn (Req.search q ix) - diff --git a/src/Network/Riak/Tag.hs b/src/Network/Riak/Tag.hs --- a/src/Network/Riak/Tag.hs +++ b/src/Network/Riak/Tag.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | @@ -20,7 +21,9 @@ import Data.Binary.Put (Put, putWord8) import Data.Word (Word8) import qualified Data.HashMap.Strict as HM +#if __GLASGOW_HASKELL__ <= 708 import Control.Applicative +#endif import Data.Tuple (swap) import Network.Riak.Protocol.DeleteRequest import Network.Riak.Protocol.ErrorResponse @@ -394,4 +397,3 @@ -- (254,RpbAuthResp), -- (255,RpbStartTls) ] - diff --git a/tests/CRDTProperties.hs b/tests/CRDTProperties.hs --- a/tests/CRDTProperties.hs +++ b/tests/CRDTProperties.hs @@ -4,7 +4,7 @@ -- license: Apache -- {-# LANGUAGE OverloadedStrings, FlexibleContexts, TupleSections, ScopedTypeVariables, - GADTs, StandaloneDeriving, UndecidableInstances, PatternGuards, MultiParamTypeClasses #-} + GADTs, StandaloneDeriving, UndecidableInstances, PatternGuards, MultiParamTypeClasses, CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module CRDTProperties (prop_counters, prop_sets, @@ -16,7 +16,9 @@ -- command output to list :: [Maybe RiakReturnValue]. Then see it we -- get the same list of results simulating Riak in this module. +#if __GLASGOW_HASKELL__ <= 708 import Control.Applicative +#endif import Control.Monad.RWS import Data.ByteString.Lazy (ByteString) import Data.Default.Class @@ -181,7 +183,8 @@ C.MapFlagOp <$> arbitrary ] -- TODO Fix this -instance Arbitrary C.Map +instance Arbitrary C.Map where + arbitrary = pure (C.Map Map.empty) -- | Abstract machine. -- Yields a value on 'Get', modifies state on 'Update'. diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -6,31 +6,31 @@ module Main where import Control.Monad +#if __GLASGOW_HASKELL__ <= 708 import Control.Applicative -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.Sequence as Seq -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Foldable (toList) +#endif +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Sequence as Seq +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Foldable (toList) import Data.Semigroup -import Data.Text (Text) -import Control.Applicative -import Control.Concurrent (threadDelay) +import Data.Text (Text) +import Control.Concurrent (threadDelay) import Control.Exception -import qualified Network.Riak as Riak -import qualified Network.Riak.Basic as B -import qualified Network.Riak.Content as B -import qualified Network.Riak.Content as B (binary,Content) -import qualified Network.Riak.CRDT as C -import qualified Network.Riak.CRDT.Riak as C -import qualified Network.Riak.Search as S -import qualified Network.Riak.Cluster as Riak -import qualified Network.Riak.JSON as J -import Network.Riak.Resolvable (ResolvableMonoid (..)) -import Network.Riak.Types hiding (key) +import qualified Network.Riak as Riak +import qualified Network.Riak.Basic as B +import qualified Network.Riak.Content as B (binary,Content,value) +import qualified Network.Riak.CRDT as C +import qualified Network.Riak.CRDT.Riak as C +import qualified Network.Riak.Search as S +import qualified Network.Riak.Cluster as Riak +import qualified Network.Riak.JSON as J +import Network.Riak.Resolvable (ResolvableMonoid (..)) +import Network.Riak.Types hiding (key) import qualified Network.Riak.Protocol.ErrorResponse as ER import qualified Properties -import qualified CRDTProperties as CRDT +import qualified CRDTProperties as CRDT import Common import Test.Tasty import Test.Tasty.HUnit @@ -140,7 +140,7 @@ $ C.xlookup "X" C.MapMapTag d where act c = do C.mapSendUpdate c btype buck key [mapOp] - C.get c btype buck key + C.get c btype buck key btype = "maps" fieldX = C.MapField C.MapMapTag "X" @@ -182,9 +182,9 @@ getIndex :: TestTree getIndex = testCase "getIndex" $ do conn <- Riak.connect Riak.defaultClient - all <- S.getIndex conn Nothing + all' <- S.getIndex conn Nothing one <- S.getIndex conn (Just "set-ix") - assertBool "all indeces" $ not (null all) + assertBool "all indeces" $ not (null all') assertEqual "set index" 1 (length one) bucketTypes :: TestTree @@ -230,11 +230,10 @@ putSome f bt c = f c bt buck key Nothing val Default Default shouldBeOK act = act >> assertBool "ok" True - shouldThrow act = catch (act >> assertBool "exception" False) (\(e::ER.ErrorResponse) -> pure ()) + shouldThrow act = catch (act >> assertBool "exception" False) (\(_e::ER.ErrorResponse) -> pure ()) btype = Just "untyped-1" noBtype = Just "no such type" buck = "xxx" key = "0" val = B.binary "" -