Bryan O'Sullivan avatar Bryan O'Sullivan committed 6f5ba66

Much ado about compilation warnings.

Comments (0)

Files changed (42)

 ^dist$
 ^tests/benchmarks/.*\.txt$
 ^tests/(?:\.hpc|bm|qc|qc-hpc|stdio-hpc|text/test)$
-\.(?:aux|eventlog|h[ip]|log|[oa]|orig|prof|ps|rej|swp)$
+\.(?:aux|eventlog|h[ip]|imports|log|[oa]|orig|prof|ps|rej|swp)$
 ~$
 syntax: glob
 .\#*
     src/riakclient.proto src/riakextra.proto > src/Protocol.proto
 
 (cd src && hprotoc -p Network.Riak Protocol.proto)
+for i in $(find src/Network/Riak/Protocol -name '*.hs';
+           echo src/Network/Riak/Protocol.hs); do
+    cp /dev/null $i.$$
+    echo '{-# LANGUAGE DeriveDataTypeable #-}' >> $i.$$
+    echo '{-# LANGUAGE FlexibleInstances #-}' >> $i.$$
+    echo '{-# LANGUAGE MultiParamTypeClasses #-}' >> $i.$$
+    echo '{-# OPTIONS_GHC -fno-warn-unused-imports #-}' >> $i.$$
+    cat $i >> $i.$$
+    mv $i.$$ $i
+done
 
 rm src/Protocol.proto
   README.md src/riakclient.proto
 cabal-version:       >=1.8
 
+flag developer
+  description: operate in developer mode
+  default: False
+
 library
   hs-source-dirs: src
 
   exposed-modules:     
     Network.Riak
+    Network.Riak.Connection
     Network.Riak.Content
+    Network.Riak.Simple
     Network.Riak.Types
-
-  other-modules:       
-    Network.Riak.Message.Tag
-    Network.Riak.Types.Internal
-    Network.Riak.Message
-    Network.Riak.Socket
-    Network.Riak.Protocol
+    Network.Riak.Protocol.ServerInfo
     Network.Riak.Protocol.BucketProps
     Network.Riak.Protocol.Content
     Network.Riak.Protocol.DeleteRequest
     Network.Riak.Protocol.GetClientIDResponse
     Network.Riak.Protocol.GetRequest
     Network.Riak.Protocol.GetResponse
-    Network.Riak.Protocol.ServerInfo
     Network.Riak.Protocol.Link
     Network.Riak.Protocol.ListBucketsResponse
     Network.Riak.Protocol.ListKeysRequest
     Network.Riak.Protocol.SetClientIDResponse
     Network.Riak.Protocol.GetServerInfoRequest
     Network.Riak.Protocol.ListBucketsRequest
+
+  other-modules:       
+    Network.Riak.Connection.Internal
+    Network.Riak.Tag
+    Network.Riak.Types.Internal
+    Network.Riak.Protocol
   
   build-depends:       
     base == 4.*,
     protocol-buffers-descriptor >= 1.8.1,
     pureMD5,
     random
-  
-  -- needed for the code generated by hprotoc
-  extensions:
-    DeriveDataTypeable FlexibleInstances MultiParamTypeClasses
+
+  if flag(developer)
+    ghc-options: -Werror
+    cpp-options: -DASSERTS
+
+  ghc-options: -Wall -fno-warn-orphans
 
   -- gather extensive profiling data for now
   ghc-prof-options: -auto-all

src/Network/Riak.hs

-{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
-
 module Network.Riak
     (
+    -- * Client configuration and identification
       ClientID
     , Client(..)
-    , Connection(connClient)
-    , Network.Riak.connect
     , defaultClient
-    , makeClientID
+    , getClientID
+    -- * Connection management
+    , Connection(..)
+    , connect
+    , disconnect
     , ping
-    , getClientID
-    , setClientID
     , getServerInfo
+    -- * Data management
     , get
-    , Network.Riak.put
+    , put
     , delete
+    -- * Metadata
     , listBuckets
     , listKeys
     , getBucket
     , setBucket
+    -- * Map/reduce
     , mapReduce
     ) where
 
-import qualified Data.ByteString.Char8 as B
-import Control.Applicative
-import Data.Binary hiding (get)
-import Data.Binary.Put
-import Control.Monad
-import Network.Socket.ByteString.Lazy as L
-import Network.Socket as Socket
-import Network.Riak.Protocol.Content
-import Network.Riak.Protocol.PutRequest
-import Network.Riak.Protocol.BucketProps
-import Network.Riak.Protocol.PutResponse
-import Network.Riak.Protocol.DeleteRequest
-import Network.Riak.Protocol.ServerInfo
-import Network.Riak.Protocol.ListBucketsResponse
-import Network.Riak.Protocol.ListKeysRequest
-import Network.Riak.Protocol.SetBucketRequest
-import Network.Riak.Protocol.ListKeysResponse
-import Network.Riak.Protocol.PingRequest
-import Network.Riak.Protocol.GetClientIDRequest
-import Network.Riak.Protocol.GetServerInfoRequest
-import Network.Riak.Protocol.ListBucketsRequest
-import qualified Data.ByteString.Lazy.Char8 as L
-import Numeric (showHex)
-import System.Random
-import Network.Riak.Protocol.GetRequest as GetRequest
-import Network.Riak.Protocol.GetResponse
-import Network.Riak.Protocol.GetBucketRequest
-import Network.Riak.Protocol.MapReduceRequest
-import Network.Riak.Protocol.MapReduce
-import Network.Riak.Protocol.GetBucketResponse as GetBucketResponse
-import Network.Riak.Protocol.SetClientIDRequest
-import Network.Riak.Protocol.GetClientIDResponse as GetClientIDResponse
-import Network.Riak.Message
-import Network.Riak.Types as T
-import qualified Network.Riak.Types.Internal as T
-import Network.Riak.Types.Internal (VClock(..), Quorum(..))
-import Text.ProtocolBuffers
-import Data.IORef
-
-defaultClient :: Client
-defaultClient = Client {
-                  host = "127.0.0.1"
-                , port = "8087"
-                , prefix = "riak"
-                , mapReducePrefix = "mapred"
-                , clientID = L.empty
-                }
-
-makeClientID :: IO ClientID
-makeClientID = do
-  r <- randomIO :: IO Int
-  return . L.append "hs_" . L.pack . showHex (abs r) $ ""
-
-addClientID :: Client -> IO Client
-addClientID client
-  | L.null (clientID client) = do
-    i <- makeClientID
-    return client { clientID = i }
-  | otherwise = return client
-
-connect :: Client -> IO Connection
-connect cli0 = do
-  client@Client{..} <- addClientID cli0
-  let hints = defaultHints
-  (ai:_) <- getAddrInfo (Just hints) (Just host) (Just port)
-  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
-
-ping :: Connection -> IO ()
-ping conn@Connection{..} = do
-  sendRequest conn PingRequest
-  recvResponse_ conn T.PingResponse
-
-getClientID :: Connection -> ClientID -> IO ClientID
-getClientID conn id = do
-  sendRequest conn GetClientIDRequest
-  GetClientIDResponse.client_id <$> recvResponse conn
-
-setClientID :: Connection -> ClientID -> IO ()
-setClientID conn id = do
-  sendRequest conn $ SetClientIDRequest id
-  recvResponse_ conn T.SetClientIDResponse
-
-getServerInfo :: Connection -> IO ServerInfo
-getServerInfo conn = do
-  sendRequest conn GetServerInfoRequest
-  recvResponse conn
-
-get :: Connection -> T.Bucket -> T.Key -> Maybe R
-    -> IO (Maybe (Seq Content, Maybe VClock))
-get conn@Connection{..} bucket key r = do
-  sendRequest conn GetRequest { bucket = bucket
-                              , key = key
-                              , r = fromQuorum <$> r }
-  maybe Nothing cast <$> recvMaybeResponse conn
- where cast GetResponse{..} = Just (content, VClock <$> vclock)
-
-put :: Connection -> T.Bucket -> T.Key -> Maybe T.VClock
-    -> Content -> Maybe W -> Maybe DW -> Bool
-    -> IO (Seq Content, Maybe VClock)
-put conn@Connection{..} bucket key vclock content w dw returnBody = do
-  sendRequest conn $ PutRequest bucket key (fromVClock <$> vclock) content
-                     (fromQuorum <$> w) (fromQuorum <$> dw) (Just returnBody)
-  PutResponse{..} <- recvResponse conn
-  return (content, VClock <$> vclock)
-
-delete :: Connection -> T.Bucket -> T.Key -> Maybe RW -> IO ()
-delete conn bucket key rw = do
-  sendRequest conn $ DeleteRequest bucket key (fromQuorum <$> rw)
-  recvResponse_ conn T.DeleteResponse
-
-listBuckets :: Connection -> IO (Seq T.Bucket)
-listBuckets conn = do
-  sendRequest conn $ ListBucketsRequest
-  buckets <$> recvResponse conn
-
-listKeys :: Connection -> T.Bucket -> IO (Seq T.Key, Maybe Bool)
-listKeys conn bucket = do
-  sendRequest conn $ ListKeysRequest bucket
-  ListKeysResponse{..} <- recvResponse conn
-  return (keys, done)
-
-getBucket :: Connection -> T.Bucket -> IO BucketProps
-getBucket conn bucket = do
-  sendRequest conn $ GetBucketRequest bucket
-  GetBucketResponse.props <$> recvResponse conn
-
-setBucket :: Connection -> T.Bucket -> BucketProps -> IO ()
-setBucket conn bucket props = do
-  sendRequest conn $ SetBucketRequest bucket props
-  recvResponse_ conn T.SetBucketResponse
-
-mapReduce :: Connection -> Job -> IO MapReduce
-mapReduce conn job = do
-  sendRequest conn $ case job of
-                       JSON bs -> MapReduceRequest bs "application/json"
-                       Erlang bs -> MapReduceRequest bs "application/x-erlang-binary"
-  recvResponse conn
+import Network.Riak.Connection
+import Network.Riak.Types
+import Network.Riak.Simple

src/Network/Riak/Connection.hs

+module Network.Riak.Connection
+    (
+    -- * Connection management
+      connect
+    , disconnect
+    -- * Client configuration
+    , defaultClient
+    , makeClientID
+    -- * Requests and responses
+    -- ** Sending and receiving
+    , sendRequest
+    , recvResponse
+    , recvMaybeResponse
+    , recvResponse_
+    -- ** Composing and parsing
+    , putRequest
+    , getResponse
+    ) where
+
+import Network.Riak.Connection.Internal

src/Network/Riak/Connection/Internal.hs

+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
+
+module Network.Riak.Connection.Internal
+    (
+    -- * Connection management
+      Network.Riak.Connection.Internal.connect
+    , disconnect
+    , setClientID
+    -- * Client configuration
+    , defaultClient
+    , makeClientID
+    -- * Requests and responses
+    -- ** Sending and receiving requests and responses
+    , sendRequest
+    , recvResponse
+    , recvMaybeResponse
+    , recvResponse_
+    -- ** Composing and parsing requests and responses
+    , putRequest
+    , getResponse
+    -- * ByteString receive operations
+    , recvExactly
+    , recvGet
+    , recvGetN
+    ) where
+
+import Control.Monad (unless, when)
+import Data.Binary.Put (Put, putWord32be, runPut)
+import Data.IORef (modifyIORef, newIORef, readIORef, writeIORef)
+import Data.Int (Int64)
+import Network.Riak.Protocol.SetClientIDRequest
+import Network.Riak.Tag (getTag, putTag)
+import Network.Riak.Types.Internal
+    (Client(..), ClientID, Connection(..), Request, Response, Tagged(..))
+import Network.Socket as Socket
+import qualified Network.Socket.ByteString as B
+import qualified Network.Socket.ByteString.Lazy as L
+import Numeric (showHex)
+import System.Random (randomIO)
+import Text.ProtocolBuffers (messageGetM, messagePutM, messageSize)
+import Text.ProtocolBuffers.Get (Get, Result(..), getWord32be, runGet)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy.Char8 as L
+import qualified Network.Riak.Types.Internal as T
+
+defaultClient :: Client
+defaultClient = Client {
+                  host = "127.0.0.1"
+                , port = "8087"
+                , prefix = "riak"
+                , mapReducePrefix = "mapred"
+                , clientID = L.empty
+                }
+
+-- | Tell the server our client ID.
+setClientID :: Connection -> ClientID -> IO ()
+setClientID conn i = do
+  sendRequest conn $ SetClientIDRequest i
+  recvResponse_ conn T.SetClientIDResponse
+
+-- | Generate a random client ID.
+makeClientID :: IO ClientID
+makeClientID = do
+  r <- randomIO :: IO Int
+  return . L.append "hs_" . L.pack . showHex (abs r) $ ""
+
+-- | Add a random 'ClientID' to a 'Client' if the 'Client' doesn't
+-- already have one.
+addClientID :: Client -> IO Client
+addClientID client
+  | L.null (clientID client) = do
+    i <- makeClientID
+    return client { clientID = i }
+  | otherwise = return client
+
+connect :: Client -> IO Connection
+connect cli0 = do
+  client@Client{..} <- addClientID cli0
+  let hints = defaultHints
+  (ai:_) <- getAddrInfo (Just hints) (Just host) (Just port)
+  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
+
+disconnect :: Connection -> IO ()
+disconnect Connection{..} = do
+  sClose connSock
+  writeIORef connBuffer L.empty
+
+recvWith :: (L.ByteString -> IO L.ByteString) -> Connection -> Int64
+         -> IO L.ByteString
+recvWith onError Connection{..} n0
+    | n0 <= 0 = return L.empty
+    | otherwise = do
+  bs <- readIORef connBuffer
+  let (h,t) = L.splitAt n0 bs
+      len = L.length h
+  if len == n0
+    then writeIORef connBuffer t >> return h
+    else if len == 0
+         then go [] n0
+         else go (reverse (L.toChunks t)) (n0-len)
+  where
+    maxInt = fromIntegral (maxBound :: Int)
+    go acc n
+        | n <= 0 = return (L.fromChunks (reverse acc))
+        | otherwise = do
+      let n' = min n maxInt
+      bs <- B.recv connSock (fromIntegral n')
+      let len = B.length bs
+      if len == 0
+        then onError (L.fromChunks (reverse acc))
+        else go (bs:acc) (n' - fromIntegral len)
+
+recvExactly :: Connection -> Int64 -> IO L.ByteString
+recvExactly = recvWith (const (fail "short read from network"))
+
+recvGet :: Connection -> Get a -> IO a
+recvGet Connection{..} get = do
+  let refill = do
+        bs <- L.recv connSock 16384
+        if L.null bs
+          then shutdown connSock ShutdownReceive >> return Nothing
+          else return (Just bs)
+      step (Failed _ err)    = fail err
+      step (Finished bs _ r) = writeIORef connBuffer bs >> return r
+      step (Partial k)       = (step . k) =<< refill
+  mbs <- do
+    buf <- readIORef connBuffer
+    if L.null buf
+      then refill
+      else return (Just buf)
+  case mbs of
+    Just bs -> step $ runGet get bs
+    Nothing -> fail "socket closed"
+  
+recvGetN :: Connection -> Int64 -> Get a -> IO a
+recvGetN conn n get = do
+  bs <- recvExactly conn n
+  let finish bs' r = do
+        unless (L.null bs') $ modifyIORef (connBuffer conn) (`L.append` bs')
+        return r
+  case runGet get bs of
+    Finished bs' _ r -> finish bs' r
+    Partial k    -> case k Nothing of
+                      Finished bs' _ r -> finish bs' r
+                      Failed _ err -> fail err
+                      Partial _    -> fail "parser wants more input!?"
+    Failed _ err -> fail err
+
+putRequest :: (Request req) => req -> Put
+putRequest req = do
+  putWord32be (fromIntegral (1 + messageSize req))
+  putTag (messageTag req)
+  messagePutM req
+
+getResponse :: (Response a) => T.MessageTag -> Get (Either String a)
+getResponse expected = do
+  tag <- getTag
+  if tag == expected
+    then Right `fmap` messageGetM
+    else return . Left $ "received unexpected response: expected " ++
+                         show expected ++ ", received " ++ show tag
+
+sendRequest :: (Request req) => Connection -> req -> IO ()
+sendRequest Connection{..} = L.sendAll connSock . runPut . putRequest
+
+recvResponse :: (Response a) => Connection -> IO a
+recvResponse conn = go undefined where
+  go :: Response b => b -> IO b
+  go dummy = do
+    len <- fromIntegral `fmap` recvGet conn getWord32be
+    r <- recvGetN conn len (getResponse (messageTag dummy))
+    case r of
+      Left err -> fail err
+      Right ret -> return ret
+
+recvResponse_ :: Connection -> T.MessageTag -> IO ()
+recvResponse_ conn expected = do
+  len <- fromIntegral `fmap` recvGet conn getWord32be
+  tag <- recvGet conn getTag
+  when (tag /= expected) .
+    fail $ "received unexpected response: expected " ++
+           show expected ++ ", received " ++ show tag
+  recvExactly conn (len-1) >> return ()
+
+recvMaybeResponse :: (Response a) => Connection -> IO (Maybe a)
+recvMaybeResponse conn =  go undefined where
+  go :: Response b => b -> IO (Maybe b)
+  go dummy = do
+    len <- fromIntegral `fmap` recvGet conn getWord32be
+    print len
+    if len == 1
+      then return Nothing
+      else do
+        r <- recvGetN conn len (getResponse (messageTag dummy))
+        case r of
+          Left err -> fail err
+          Right ret -> return (Just ret)

src/Network/Riak/Content.hs

 
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified Data.Sequence as Seq
-import Network.Riak.Protocol.Content as Rpb
-import Network.Riak.Types
+import Network.Riak.Protocol.Content (Content(..))
 
 unspecified :: Content
 unspecified = Content { value = L.empty
-                         , content_type = Nothing
-                         , charset = Nothing
-                         , content_encoding = Nothing
-                         , vtag = Nothing
-                         , links = Seq.empty
-                         , last_mod = Nothing
-                         , last_mod_usecs = Nothing
-                         , usermeta = Seq.empty
-                         }
+                      , content_type = Nothing
+                      , charset = Nothing
+                      , content_encoding = Nothing
+                      , vtag = Nothing
+                      , links = Seq.empty
+                      , last_mod = Nothing
+                      , last_mod_usecs = Nothing
+                      , usermeta = Seq.empty
+                      }
 
 binary :: L.ByteString -> Content
 binary bs = unspecified { value = bs

src/Network/Riak/Message.hs

-{-# LANGUAGE ExistentialQuantification, RecordWildCards #-}
-
-module Network.Riak.Message
-    (
-      getResponse
-    , putPingRequest
-    , recvResponse_
-    , recvResponse
-    , recvMaybeResponse
-    , sendRequest
-    ) where
-
-import Control.Monad
-import Data.Binary hiding (Get)
-import Data.Binary.Put
-import Data.ByteString.Lazy as L
-import Data.IntMap as Map
-import Network.Socket
-import Network.Riak.Socket
-import Network.Riak.Types
-import Network.Riak.Types.Internal
-import Network.Riak.Message.Tag
-import Text.ProtocolBuffers as PB
-import Text.ProtocolBuffers.Get
-import Network.Riak.Protocol.GetResponse
-import Network.Riak.Protocol.PutResponse
-import Network.Riak.Protocol.GetClientIDResponse
-import Network.Socket.ByteString.Lazy as L
-
-putPingRequest :: Put
-putPingRequest = putWord32be 1 >> putTag PingRequest
-
-putRequest :: (Request req) => req -> Put
-putRequest req = do
-  putWord32be (fromIntegral (1 + messageSize req))
-  putTag (messageTag req)
-  messagePutM req
-
-sendRequest :: (Request req) => Connection -> req -> IO ()
-sendRequest Connection{..} req = L.sendAll connSock . runPut . putRequest $ req
-
-getResponse :: Response a => MessageTag -> Get (Either String a)
-getResponse expected = do
-  tag <- getTag
-  if tag == expected
-    then Right `fmap` messageGetM
-    else return . Left $ "received unexpected response: expected " ++
-                         show expected ++ ", received " ++ show tag
-
-recvResponse :: Response a => Connection -> IO a
-recvResponse conn = go undefined where
-  go :: Response b => b -> IO b
-  go dummy = do
-    len <- fromIntegral `fmap` recvGet conn getWord32be
-    r <- recvGetN conn len (getResponse (messageTag dummy))
-    case r of
-      Left err -> fail err
-      Right ret -> return ret
-
-recvResponse_ :: Connection -> MessageTag -> IO ()
-recvResponse_ conn expected = do
-  len <- fromIntegral `fmap` recvGet conn getWord32be
-  tag <- recvGet conn getTag
-  when (tag /= expected) .
-    fail $ "received unexpected response: expected " ++
-           show expected ++ ", received " ++ show tag
-  recvExactly conn (len-1) >> return ()
-
-recvMaybeResponse :: Response a => Connection -> IO (Maybe a)
-recvMaybeResponse conn =  go undefined where
-  go :: Response b => b -> IO (Maybe b)
-  go dummy = do
-    len <- fromIntegral `fmap` recvGet conn getWord32be
-    print len
-    if len == 1
-      then return Nothing
-      else do
-        r <- recvGetN conn len (getResponse (messageTag dummy))
-        case r of
-          Left err -> fail err
-          Right ret -> return (Just ret)

src/Network/Riak/Message/Tag.hs

-module Network.Riak.Message.Tag
-    (
-      Tagged(..)
-    , MessageTag
-    , putTag
-    , getTag
-    ) where
-
-import Data.Typeable
-import Control.Monad (liftM)
-import Data.Word (Word8)
-import Data.Binary.Put
-import Network.Riak.Protocol.SetClientIDRequest
-import Network.Riak.Protocol.PingResponse
-import Network.Riak.Protocol.GetRequest
-import Network.Riak.Protocol.GetResponse
-import Network.Riak.Protocol.PutRequest
-import Network.Riak.Protocol.PutResponse
-import Network.Riak.Protocol.DeleteRequest
-import Network.Riak.Protocol.ListKeysResponse
-import Network.Riak.Protocol.GetClientIDResponse
-import Network.Riak.Protocol.ServerInfo
-import Network.Riak.Protocol.SetClientIDResponse
-import Network.Riak.Protocol.GetServerInfoRequest
-import Network.Riak.Protocol.ListKeysRequest
-import Network.Riak.Protocol.GetBucketRequest
-import Network.Riak.Protocol.GetBucketResponse
-import Network.Riak.Protocol.SetBucketRequest
-import Network.Riak.Protocol.ListBucketsResponse
-import Network.Riak.Protocol.MapReduceRequest
-import Network.Riak.Protocol.MapReduce
-import Network.Riak.Protocol.PingRequest
-import Network.Riak.Protocol.GetClientIDRequest
-import Network.Riak.Protocol.ListBucketsRequest
-import Text.ProtocolBuffers
-import Text.ProtocolBuffers.Get
-import Network.Riak.Types.Internal as Types
-
-instance Tagged PingRequest where
-    messageTag _ = Types.PingRequest
-    {-# INLINE messageTag #-}
-
-instance Request PingRequest
-
-instance Tagged PingResponse where
-    messageTag _ = Types.PingResponse
-    {-# INLINE messageTag #-}
-
-instance Response PingResponse
-
-instance Tagged GetClientIDRequest where
-    messageTag _ = Types.GetClientIDRequest
-    {-# INLINE messageTag #-}
-
-instance Request GetClientIDRequest
-
-instance Tagged GetClientIDResponse where
-    messageTag _ = Types.GetClientIDResponse
-    {-# INLINE messageTag #-}
-
-instance Response GetClientIDResponse
-
-instance Tagged SetClientIDRequest where
-    messageTag _ = Types.SetClientIDRequest
-    {-# INLINE messageTag #-}
-
-instance Request SetClientIDRequest
-
-instance Tagged GetServerInfoRequest where
-    messageTag _ = Types.GetServerInfoRequest
-    {-# INLINE messageTag #-}
-
-instance Request GetServerInfoRequest
-
-instance Tagged ServerInfo where
-    messageTag _ = Types.GetServerInfoResponse
-    {-# INLINE messageTag #-}
-
-instance Response ServerInfo
-
-instance Tagged GetRequest where
-    messageTag _ = Types.GetRequest
-    {-# INLINE messageTag #-}
-
-instance Request GetRequest
-
-instance Tagged GetResponse where
-    messageTag _ = Types.GetResponse
-    {-# INLINE messageTag #-}
-
-instance Response GetResponse
-
-instance Tagged PutRequest where
-    messageTag _ = Types.PutRequest
-    {-# INLINE messageTag #-}
-
-instance Request PutRequest
-
-instance Tagged PutResponse where
-    messageTag _ = Types.PutResponse
-    {-# INLINE messageTag #-}
-
-instance Response PutResponse
-
-instance Tagged DeleteRequest where
-    messageTag _ = Types.DeleteRequest
-    {-# INLINE messageTag #-}
-
-instance Request DeleteRequest
-
-instance Tagged ListBucketsRequest where
-    messageTag _ = Types.ListBucketsRequest
-    {-# INLINE messageTag #-}
-
-instance Request ListBucketsRequest
-
-instance Tagged ListBucketsResponse where
-    messageTag _ = Types.ListBucketsResponse
-    {-# INLINE messageTag #-}
-
-instance Response ListBucketsResponse
-
-instance Tagged ListKeysRequest where
-    messageTag _ = Types.ListKeysRequest
-    {-# INLINE messageTag #-}
-
-instance Request ListKeysRequest
-
-instance Tagged ListKeysResponse where
-    messageTag _ = Types.ListKeysResponse
-    {-# INLINE messageTag #-}
-
-instance Response ListKeysResponse
-
-instance Tagged GetBucketRequest where
-    messageTag _ = Types.GetBucketRequest
-    {-# INLINE messageTag #-}
-
-instance Request GetBucketRequest
-
-instance Tagged GetBucketResponse where
-    messageTag _ = Types.GetBucketResponse
-    {-# INLINE messageTag #-}
-
-instance Response GetBucketResponse
-
-instance Tagged SetBucketRequest where
-    messageTag _ = Types.SetBucketRequest
-    {-# INLINE messageTag #-}
-
-instance Request SetBucketRequest
-
-instance Tagged MapReduceRequest where
-    messageTag _ = Types.MapReduceRequest
-    {-# INLINE messageTag #-}
-
-instance Request MapReduceRequest
-
-instance Tagged MapReduce where
-    messageTag _ = Types.MapReduceResponse
-    {-# INLINE messageTag #-}
-
-instance Response MapReduce
-
-putTag :: MessageTag -> Put
-putTag = putWord8 . fromIntegral . fromEnum
-{-# INLINE putTag #-}
-
-getTag :: Get MessageTag
-getTag = do
-  n <- getWord8
-  if n > 24
-    then fail $ "invalid riak message code: " ++ show n
-    else return .  toEnum . fromIntegral $ n
-{-# INLINE getTag #-}

src/Network/Riak/Protocol.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol (protoInfo, fileDescriptorProto) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/BucketProps.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.BucketProps (BucketProps(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/Content.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.Content (Content(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/DeleteRequest.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.DeleteRequest (DeleteRequest(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/ErrorResponse.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.ErrorResponse (ErrorResponse(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/GetBucketRequest.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.GetBucketRequest (GetBucketRequest(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/GetBucketResponse.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.GetBucketResponse (GetBucketResponse(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/GetClientIDRequest.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.GetClientIDRequest (GetClientIDRequest(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/GetClientIDResponse.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.GetClientIDResponse (GetClientIDResponse(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/GetRequest.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.GetRequest (GetRequest(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/GetResponse.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.GetResponse (GetResponse(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/GetServerInfoRequest.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.GetServerInfoRequest (GetServerInfoRequest(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/Link.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.Link (Link(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/ListBucketsRequest.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.ListBucketsRequest (ListBucketsRequest(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/ListBucketsResponse.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.ListBucketsResponse (ListBucketsResponse(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/ListKeysRequest.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.ListKeysRequest (ListKeysRequest(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/ListKeysResponse.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.ListKeysResponse (ListKeysResponse(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/MapReduce.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.MapReduce (MapReduce(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/MapReduceRequest.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.MapReduceRequest (MapReduceRequest(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/Pair.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.Pair (Pair(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/PingRequest.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.PingRequest (PingRequest(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/PingResponse.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.PingResponse (PingResponse(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/PutRequest.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.PutRequest (PutRequest(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/PutResponse.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.PutResponse (PutResponse(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/ServerInfo.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.ServerInfo (ServerInfo(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/SetBucketRequest.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.SetBucketRequest (SetBucketRequest(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/SetClientIDRequest.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.SetClientIDRequest (SetClientIDRequest(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Protocol/SetClientIDResponse.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 module Network.Riak.Protocol.SetClientIDResponse (SetClientIDResponse(..)) where
 import Prelude ((+))
 import qualified Prelude as P'

src/Network/Riak/Simple.hs

+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
+
+module Network.Riak.Simple
+    (
+    -- * Connection management
+      ping
+    , getClientID
+    , setClientID
+    , getServerInfo
+    -- * Data management
+    , get
+    , put
+    , delete
+    -- * Metadata
+    , listBuckets
+    , listKeys
+    , getBucket
+    , setBucket
+    -- * Map/reduce
+    , mapReduce
+    ) where
+
+import Control.Applicative ((<$>))
+import Data.Sequence (Seq)
+import Network.Riak.Connection.Internal
+import Network.Riak.Protocol.BucketProps
+import Network.Riak.Protocol.Content
+import Network.Riak.Protocol.DeleteRequest
+import Network.Riak.Protocol.GetBucketRequest
+import Network.Riak.Protocol.GetBucketResponse as GetBucketResponse
+import Network.Riak.Protocol.GetClientIDRequest
+import Network.Riak.Protocol.GetClientIDResponse as GetClientIDResponse
+import Network.Riak.Protocol.GetRequest as GetRequest
+import Network.Riak.Protocol.GetResponse
+import Network.Riak.Protocol.GetServerInfoRequest
+import Network.Riak.Protocol.ListBucketsRequest
+import Network.Riak.Protocol.ListBucketsResponse
+import Network.Riak.Protocol.ListKeysRequest
+import Network.Riak.Protocol.ListKeysResponse
+import Network.Riak.Protocol.MapReduce
+import Network.Riak.Protocol.MapReduceRequest
+import Network.Riak.Protocol.PingRequest
+import Network.Riak.Protocol.PutRequest
+import Network.Riak.Protocol.PutResponse
+import Network.Riak.Protocol.ServerInfo
+import Network.Riak.Protocol.SetBucketRequest
+import Network.Riak.Types.Internal hiding (MessageTag(..))
+import qualified Network.Riak.Types.Internal as T
+
+ping :: Connection -> IO ()
+ping conn@Connection{..} = do
+  sendRequest conn PingRequest
+  recvResponse_ conn T.PingResponse
+
+getClientID :: Connection -> IO ClientID
+getClientID conn = do
+  sendRequest conn GetClientIDRequest
+  GetClientIDResponse.client_id <$> recvResponse conn
+
+getServerInfo :: Connection -> IO ServerInfo
+getServerInfo conn = do
+  sendRequest conn GetServerInfoRequest
+  recvResponse conn
+
+get :: Connection -> T.Bucket -> T.Key -> Maybe R
+    -> IO (Maybe (Seq Content, Maybe VClock))
+get conn@Connection{..} bucket key r = do
+  sendRequest conn GetRequest { bucket = bucket
+                              , key = key
+                              , r = fromQuorum <$> r }
+  maybe Nothing cast <$> recvMaybeResponse conn
+ where cast GetResponse{..} = Just (content, VClock <$> vclock)
+
+put :: Connection -> T.Bucket -> T.Key -> Maybe T.VClock
+    -> Content -> Maybe W -> Maybe DW -> Bool
+    -> IO (Seq Content, Maybe VClock)
+put conn@Connection{..} bucket key mvclock cont mw mdw returnBody = do
+  sendRequest conn $ PutRequest bucket key (fromVClock <$> mvclock) cont
+                     (fromQuorum <$> mw) (fromQuorum <$> mdw) (Just returnBody)
+  PutResponse{..} <- recvResponse conn
+  return (content, VClock <$> vclock)
+
+delete :: Connection -> T.Bucket -> T.Key -> Maybe RW -> IO ()
+delete conn bucket key rw = do
+  sendRequest conn $ DeleteRequest bucket key (fromQuorum <$> rw)
+  recvResponse_ conn T.DeleteResponse
+
+listBuckets :: Connection -> IO (Seq T.Bucket)
+listBuckets conn = do
+  sendRequest conn $ ListBucketsRequest
+  buckets <$> recvResponse conn
+
+listKeys :: Connection -> T.Bucket -> IO (Seq T.Key, Maybe Bool)
+listKeys conn bucket = do
+  sendRequest conn $ ListKeysRequest bucket
+  ListKeysResponse{..} <- recvResponse conn
+  return (keys, done)
+
+getBucket :: Connection -> T.Bucket -> IO BucketProps
+getBucket conn bucket = do
+  sendRequest conn $ GetBucketRequest bucket
+  GetBucketResponse.props <$> recvResponse conn
+
+setBucket :: Connection -> T.Bucket -> BucketProps -> IO ()
+setBucket conn bucket props = do
+  sendRequest conn $ SetBucketRequest bucket props
+  recvResponse_ conn T.SetBucketResponse
+
+mapReduce :: Connection -> Job -> IO MapReduce
+mapReduce conn job = do
+  sendRequest conn $ case job of
+                       JSON bs -> MapReduceRequest bs "application/json"
+                       Erlang bs -> MapReduceRequest bs "application/x-erlang-binary"
+  recvResponse conn

src/Network/Riak/Socket.hs

-{-# LANGUAGE RecordWildCards #-}
-
-module Network.Riak.Socket
-    (
-      recvExactly
-    , recvGet
-    , recvGetN
-    ) where
-
-import Control.Monad
-import qualified Data.ByteString.Lazy as L
-import qualified Data.ByteString as B
-import Network.Socket
-import Network.Socket.ByteString as B
-import Network.Socket.ByteString.Lazy as L
-import Data.Int
-import Text.ProtocolBuffers.Get
-import Network.Riak.Types
-import Data.IORef
-
-recvWith :: (L.ByteString -> IO L.ByteString) -> Connection -> Int64
-         -> IO L.ByteString
-recvWith onError Connection{..} n0
-    | n0 <= 0 = return L.empty
-    | otherwise = do
-  bs <- readIORef connBuffer
-  let (h,t) = L.splitAt n0 bs
-      len = L.length h
-  if len == n0
-    then writeIORef connBuffer t >> return h
-    else if len == 0
-         then go [] n0
-         else go (reverse (L.toChunks t)) (n0-len)
-  where
-    maxInt = fromIntegral (maxBound :: Int)
-    go acc n
-        | n <= 0 = return (L.fromChunks (reverse acc))
-        | otherwise = do
-      let n' = min n maxInt
-      bs <- B.recv connSock (fromIntegral n')
-      let len = B.length bs
-      if len == 0
-        then onError (L.fromChunks (reverse acc))
-        else go (bs:acc) (n' - fromIntegral len)
-
-recvExactly :: Connection -> Int64 -> IO L.ByteString
-recvExactly = recvWith (const (fail "short read from network"))
-
-recvGet :: Connection -> Get a -> IO a
-recvGet Connection{..} get = do
-  let refill = do
-        bs <- L.recv connSock 16384
-        if L.null bs
-          then shutdown connSock ShutdownReceive >> return Nothing
-          else return (Just bs)
-      step (Failed _ err)    = fail err
-      step (Finished bs _ r) = writeIORef connBuffer bs >> return r
-      step (Partial k)       = (step . k) =<< refill
-  mbs <- do
-    buf <- readIORef connBuffer
-    if L.null buf
-      then refill
-      else return (Just buf)
-  case mbs of
-    Just bs -> step $ runGet get bs
-    Nothing -> fail "socket closed"
-  
-recvGetN :: Connection -> Int64 -> Get a -> IO a
-recvGetN conn n get = do
-  bs <- recvExactly conn n
-  let finish bs' r = do
-        unless (L.null bs') $ modifyIORef (connBuffer conn) (`L.append` bs')
-        return r
-  case runGet get bs of
-    Finished bs' _ r -> finish bs' r
-    Partial k    -> case k Nothing of
-                      Finished bs' _ r -> finish bs' r
-                      Failed _ err -> fail err
-                      Partial _    -> fail "parser wants more input!?"
-    Failed _ err -> fail err

src/Network/Riak/Tag.hs

+module Network.Riak.Tag
+    (
+      Tagged(..)
+    , MessageTag
+    , putTag
+    , getTag
+    ) where
+
+import Data.Binary.Put (Put, putWord8)
+import Network.Riak.Protocol.DeleteRequest
+import Network.Riak.Protocol.GetBucketRequest
+import Network.Riak.Protocol.GetBucketResponse
+import Network.Riak.Protocol.GetClientIDRequest
+import Network.Riak.Protocol.GetClientIDResponse
+import Network.Riak.Protocol.GetRequest
+import Network.Riak.Protocol.GetResponse
+import Network.Riak.Protocol.GetServerInfoRequest
+import Network.Riak.Protocol.ListBucketsRequest
+import Network.Riak.Protocol.ListBucketsResponse
+import Network.Riak.Protocol.ListKeysRequest
+import Network.Riak.Protocol.ListKeysResponse
+import Network.Riak.Protocol.MapReduce
+import Network.Riak.Protocol.MapReduceRequest
+import Network.Riak.Protocol.PingRequest
+import Network.Riak.Protocol.PingResponse
+import Network.Riak.Protocol.PutRequest
+import Network.Riak.Protocol.PutResponse
+import Network.Riak.Protocol.ServerInfo
+import Network.Riak.Protocol.SetBucketRequest
+import Network.Riak.Protocol.SetClientIDRequest
+import Network.Riak.Protocol.SetClientIDResponse
+import Network.Riak.Types.Internal as Types
+import Text.ProtocolBuffers.Get (Get, getWord8)
+
+instance Tagged PingRequest where
+    messageTag _ = Types.PingRequest
+    {-# INLINE messageTag #-}
+
+instance Request PingRequest
+
+instance Tagged PingResponse where
+    messageTag _ = Types.PingResponse
+    {-# INLINE messageTag #-}
+
+instance Response PingResponse
+
+instance Tagged GetClientIDRequest where
+    messageTag _ = Types.GetClientIDRequest
+    {-# INLINE messageTag #-}
+
+instance Request GetClientIDRequest
+
+instance Tagged GetClientIDResponse where
+    messageTag _ = Types.GetClientIDResponse
+    {-# INLINE messageTag #-}
+
+instance Response GetClientIDResponse
+
+instance Tagged SetClientIDRequest where
+    messageTag _ = Types.SetClientIDRequest
+    {-# INLINE messageTag #-}
+
+instance Request SetClientIDRequest
+
+instance Tagged SetClientIDResponse where
+    messageTag _ = Types.SetClientIDResponse
+    {-# INLINE messageTag #-}
+
+instance Request SetClientIDResponse
+
+instance Tagged GetServerInfoRequest where
+    messageTag _ = Types.GetServerInfoRequest
+    {-# INLINE messageTag #-}
+
+instance Request GetServerInfoRequest
+
+instance Tagged ServerInfo where
+    messageTag _ = Types.GetServerInfoResponse
+    {-# INLINE messageTag #-}
+
+instance Response ServerInfo
+
+instance Tagged GetRequest where
+    messageTag _ = Types.GetRequest
+    {-# INLINE messageTag #-}
+
+instance Request GetRequest
+
+instance Tagged GetResponse where
+    messageTag _ = Types.GetResponse
+    {-# INLINE messageTag #-}
+
+instance Response GetResponse
+
+instance Tagged PutRequest where
+    messageTag _ = Types.PutRequest
+    {-# INLINE messageTag #-}
+
+instance Request PutRequest
+
+instance Tagged PutResponse where
+    messageTag _ = Types.PutResponse
+    {-# INLINE messageTag #-}
+
+instance Response PutResponse
+
+instance Tagged DeleteRequest where
+    messageTag _ = Types.DeleteRequest
+    {-# INLINE messageTag #-}
+
+instance Request DeleteRequest
+
+instance Tagged ListBucketsRequest where
+    messageTag _ = Types.ListBucketsRequest
+    {-# INLINE messageTag #-}
+
+instance Request ListBucketsRequest
+
+instance Tagged ListBucketsResponse where
+    messageTag _ = Types.ListBucketsResponse
+    {-# INLINE messageTag #-}
+
+instance Response ListBucketsResponse
+
+instance Tagged ListKeysRequest where
+    messageTag _ = Types.ListKeysRequest
+    {-# INLINE messageTag #-}
+
+instance Request ListKeysRequest
+
+instance Tagged ListKeysResponse where
+    messageTag _ = Types.ListKeysResponse
+    {-# INLINE messageTag #-}
+
+instance Response ListKeysResponse
+
+instance Tagged GetBucketRequest where
+    messageTag _ = Types.GetBucketRequest
+    {-# INLINE messageTag #-}
+
+instance Request GetBucketRequest
+
+instance Tagged GetBucketResponse where
+    messageTag _ = Types.GetBucketResponse
+    {-# INLINE messageTag #-}
+
+instance Response GetBucketResponse
+
+instance Tagged SetBucketRequest where
+    messageTag _ = Types.SetBucketRequest
+    {-# INLINE messageTag #-}
+
+instance Request SetBucketRequest
+
+instance Tagged MapReduceRequest where
+    messageTag _ = Types.MapReduceRequest
+    {-# INLINE messageTag #-}
+
+instance Request MapReduceRequest
+
+instance Tagged MapReduce where
+    messageTag _ = Types.MapReduceResponse
+    {-# INLINE messageTag #-}
+
+instance Response MapReduce
+
+putTag :: MessageTag -> Put
+putTag = putWord8 . fromIntegral . fromEnum
+{-# INLINE putTag #-}
+
+getTag :: Get MessageTag
+getTag = do
+  n <- getWord8
+  if n > 24
+    then fail $ "invalid riak message code: " ++ show n
+    else return .  toEnum . fromIntegral $ n
+{-# INLINE getTag #-}

src/Network/Riak/Types.hs

 module Network.Riak.Types
     (
+    -- * Client management
       ClientID
     , Client(..)
-    , Job(..)
-    , Connection(..)
+    -- * Connection management
+    , Connection(connClient)
+    -- * Data types
     , Bucket
     , Key
-    , Q(..)
-    , RW(..)
-    , R(..)
-    , W(..)
-    , DW(..)
-    , VClock
+    , VClock(..)
+    , Job(..)
+    -- * Quorum management
+    , Quorum(..)
+    , RW
+    , R
+    , W
+    , DW
+    -- * Message identification
+    , Request
+    , Response
+    , MessageTag(..)
+    , Tagged(..)
     ) where
 
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as L
-import Data.IORef (IORef)
-import Network.Socket
-import Network.Riak.Protocol.Content
-import Network.Riak.Protocol.ServerInfo
-import Network.Riak.Protocol.BucketProps
-import Network.Riak.Protocol.MapReduce
 import Network.Riak.Types.Internal
-    
-type ClientID = L.ByteString
-
-data Client = Client {
-      host :: HostName
-    , port :: ServiceName
-    , prefix :: B.ByteString
-    , mapReducePrefix :: B.ByteString
-    , clientID :: ClientID
-    } deriving (Eq, Show)
-
-data Connection = Connection {
-      connSock :: Socket
-    , connClient :: Client
-    , connBuffer :: IORef L.ByteString
-    } deriving (Eq)
-
-instance Show Connection where
-    show conn = show "Connection " ++ host c ++ ":" ++ port c
-        where c = connClient conn
-
-type Bucket = L.ByteString
-
-type Key = L.ByteString
-
-data Job = JSON L.ByteString
-         | Erlang L.ByteString
-           deriving (Eq, Show)

src/Network/Riak/Types/Internal.hs

 module Network.Riak.Types.Internal
     (
-      MessageTag(..)
+    -- * Client management
+      ClientID
+    , Client(..)
+    -- * Connection management
+    , Connection(..)
+    -- * Data types
+    , Bucket
+    , Key
+    , VClock(..)
+    , Job(..)
+    -- * Quorum management
+    , Quorum(..)
+    , DW
+    , R
+    , RW
+    , W
+    , fromQuorum
+    , toQuorum
+    -- * Message identification
+    , Request
+    , Response
+    , MessageTag(..)
     , Tagged(..)
-    , Request(..)
-    , Response(..)
-    , VClock(..)
-    , Q(..)
-    , RW(..)
-    , R(..)
-    , W(..)
-    , DW(..)
-    , Quorum(..)
     ) where
 
-import qualified Data.ByteString.Lazy as L
+import Data.ByteString.Lazy (ByteString)
 import Data.Digest.Pure.MD5 (md5)
-import Data.Word
-import Text.ProtocolBuffers
+import Data.IORef (IORef)
+import Data.Word (Word32)
+import Network.Socket (HostName, ServiceName, Socket)
+import Text.ProtocolBuffers (ReflectDescriptor, Wire)
+    
+type ClientID = ByteString
+
+data Client = Client {
+      host :: HostName
+    , port :: ServiceName
+    , prefix :: ByteString
+    , mapReducePrefix :: ByteString
+    , clientID :: ClientID
+    } deriving (Eq, Show)
+
+data Connection = Connection {
+      connSock :: Socket
+    , connClient :: Client
+    , connBuffer :: IORef ByteString
+    } deriving (Eq)
+
+instance Show Connection where
+    show conn = show "Connection " ++ host c ++ ":" ++ port c
+        where c = connClient conn
+
+type Bucket = ByteString
+
+type Key = ByteString
+
+data Job = JSON ByteString
+         | Erlang ByteString
+           deriving (Eq, Show)
 
 data MessageTag = ErrorResponse
                 | PingRequest
     {-# INLINE messageTag #-}
 
 newtype VClock = VClock {
-      fromVClock :: L.ByteString
+      fromVClock :: ByteString
     } deriving (Eq)
 
 instance Show VClock where
     show (VClock s) = "VClock " ++ show (md5 s)
 
-data Q = Default
-       | All
-       | Quorum
-       | One
-         deriving (Eq, Enum, Show)
+data Quorum = Default
+            | All
+            | Quorum
+            | One
+              deriving (Eq, Enum, Show)
 
-newtype RW = RW Q deriving (Eq, Show)
-newtype R  = R Q deriving (Eq, Show)
-newtype W  = W Q deriving (Eq, Show)
-newtype DW = DW Q deriving (Eq, Show)
+type RW = Quorum
+type R  = Quorum
+type W  = Quorum
+type DW = Quorum
 
-fromQ :: Q -> Word32
-fromQ Default = 4294967291
-fromQ All     = 4294967292
-fromQ Quorum  = 4294967293
-fromQ One     = 4294967294
-{-# INLINE fromQ #-}
+fromQuorum :: Quorum -> Word32
+fromQuorum Default = 4294967291
+fromQuorum All     = 4294967292
+fromQuorum Quorum  = 4294967293
+fromQuorum One     = 4294967294
+{-# INLINE fromQuorum #-}
 
-toQ :: Word32 -> Maybe Q
-toQ 4294967291 = Just Default
-toQ 4294967292 = Just All
-toQ 4294967293 = Just Quorum
-toQ 4294967294 = Just One
-toQ _          = Nothing
-{-# INLINE toQ #-}
-
-class Quorum q where
-    fromQuorum :: q -> Word32
-    toQuorum :: Word32 -> Maybe q
-
-instance Quorum Q where
-    fromQuorum = fromQ
-    {-# INLINE fromQuorum #-}
-
-    toQuorum = toQ
-    {-# INLINE toQuorum #-}
-
-instance Quorum R where
-    fromQuorum (R q) = fromQ q
-    {-# INLINE fromQuorum #-}
-
-    toQuorum = fmap R . toQ
-    {-# INLINE toQuorum #-}
-
-instance Quorum W where
-    fromQuorum (W q) = fromQ q
-    {-# INLINE fromQuorum #-}
-
-    toQuorum = fmap W . toQ
-    {-# INLINE toQuorum #-}
-
-instance Quorum RW where
-    fromQuorum (RW q) = fromQ q
-    {-# INLINE fromQuorum #-}
-
-    toQuorum = fmap RW . toQ
-    {-# INLINE toQuorum #-}
-
-instance Quorum DW where
-    fromQuorum (DW q) = fromQ q
-    {-# INLINE fromQuorum #-}
-
-    toQuorum = fmap DW . toQ
-    {-# INLINE toQuorum #-}
+toQuorum :: Word32 -> Maybe Quorum
+toQuorum 4294967291 = Just Default
+toQuorum 4294967292 = Just All
+toQuorum 4294967293 = Just Quorum
+toQuorum 4294967294 = Just One
+toQuorum _          = Nothing
+{-# INLINE toQuorum #-}
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.