riak 1.1.0.0 → 1.1.1.0
raw patch · 10 files changed
+74/−62 lines, 10 filesdep ~aesondep ~riak-protobuf
Dependency ranges changed: aeson, riak-protobuf
Files
- Changes.md +3/−0
- riak.cabal +3/−3
- src/Network/Riak/CRDT/Response.hs +5/−3
- src/Network/Riak/CRDT/Riak.hs +9/−8
- src/Network/Riak/Cluster.hs +2/−4
- src/Network/Riak/Connection/Internal.hs +12/−9
- src/Network/Riak/Search.hs +8/−7
- src/Network/Riak/Tag.hs +3/−1
- tests/CRDTProperties.hs +5/−2
- tests/Test.hs +24/−25
Changes.md view
@@ -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)
riak.cabal view
@@ -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.*,
src/Network/Riak/CRDT/Response.hs view
@@ -2,15 +2,18 @@ -- copyright: (c) 2016 Sentenai -- author: Antonio Nikishaev <me@lelf.lu> -- 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-
src/Network/Riak/CRDT/Riak.hs view
@@ -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-
src/Network/Riak/Cluster.hs view
@@ -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
src/Network/Riak/Connection/Internal.hs view
@@ -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
src/Network/Riak/Search.hs view
@@ -2,18 +2,20 @@ -- copyright: (c) 2016 Sentenai -- author: Antonio Nikishaev <me@lelf.lu> -- 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)-
src/Network/Riak/Tag.hs view
@@ -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) ]-
tests/CRDTProperties.hs view
@@ -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'.
tests/Test.hs view
@@ -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 ""-