Bryan O'Sullivan avatar Bryan O'Sullivan committed be766c2

Massive WIPpery.

Switched to type-safer send and receive methods, mostly.

Comments (0)

Files changed (17)

     Network.Riak.Types
 
   other-modules:       
-    Network.Riak.Message.Code
+    Network.Riak.Message.Tag
     Network.Riak.Types.Internal
     Network.Riak.Message
     Network.Riak.Socket
     Network.Riakclient.RpbPutResp
     Network.Riakclient.RpbSetBucketReq
     Network.Riakclient.RpbSetClientIdReq
+    Network.Riakextra
+    Network.Riakextra.RpbPingReq
+    Network.Riakextra.RpbPingResp
+    Network.Riakextra.RpbGetClientIdReq
+    Network.Riakextra.RpbSetClientIdResp
+    Network.Riakextra.RpbGetServerInfoReq
   
   build-depends:       
     base == 4.*,

src/Network/Riak.hs

     , defaultClient
     , makeClientID
     , ping
+    , getClientID
+    , setClientID
+    , getServerInfo
     , get
     , Network.Riak.put
     ) where
 import Network.Riakclient.RpbContent
 import Network.Riakclient.RpbPutReq
 import Network.Riakclient.RpbPutResp
+import Network.Riakclient.RpbGetServerInfoResp
+import Network.Riakextra.RpbPingReq
+import Network.Riakextra.RpbGetClientIdReq
+import Network.Riakextra.RpbGetServerInfoReq
 import qualified Data.ByteString.Lazy.Char8 as L
 import Numeric (showHex)
 import System.Random
-import qualified Network.Riak.Message.Code as Code
 import Network.Riakclient.RpbGetReq as GetReq
 import Network.Riakclient.RpbGetResp
 import Network.Riakclient.RpbSetClientIdReq
+import Network.Riakclient.RpbGetClientIdResp as GetClientIdResp
 import Network.Riak.Message
 import Network.Riak.Types as T
 import Network.Riak.Types.Internal
 
 defaultClient :: Client
 defaultClient = Client {
-                  riakHost = "127.0.0.1"
-                , riakPort = "8087"
-                , riakPrefix = "riak"
-                , riakMapReducePrefix = "mapred"
-                , riakClientID = L.empty
+                  host = "127.0.0.1"
+                , port = "8087"
+                , prefix = "riak"
+                , mapReducePrefix = "mapred"
+                , clientID = L.empty
                 }
 
 makeClientID :: IO ClientID
 
 addClientID :: Client -> IO Client
 addClientID client
-  | L.null (riakClientID client) = do
+  | L.null (clientID client) = do
     i <- makeClientID
-    return client { riakClientID = i }
+    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 riakHost) (Just riakPort)
+  (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 riakClientID
+  setClientID conn clientID
   return conn
 
 ping :: Connection -> IO ()
 ping conn@Connection{..} = do
-  L.sendAll connSock $ runPut putPingReq
-  _ <- recvResponse conn
-  return ()
+  sendRequest conn RpbPingReq
+  recvResponse_ conn PingResp
+
+getClientID :: Connection -> ClientID -> IO ClientID
+getClientID conn id = do
+  sendRequest conn RpbGetClientIdReq
+  GetClientIdResp.client_id <$> recvResponse conn
+
+setClientID :: Connection -> ClientID -> IO ()
+setClientID conn id = do
+  sendRequest conn $ RpbSetClientIdReq id
+  recvResponse_ conn SetClientIdResp
+
+getServerInfo :: Connection -> IO ServerInfo
+getServerInfo conn = do
+  sendRequest conn RpbGetServerInfoReq
+  recvResponse conn
 
 get :: Connection -> T.Bucket -> T.Key -> Maybe R
     -> IO (Maybe (Seq Content, Maybe VClock))
 get conn@Connection{..} bucket key r = do
-  let req = RpbGetReq { bucket = bucket, key = key, r = fromQuorum <$> r }
-  sendRequest conn req
-  resp <- recvResponse conn
-  case resp of
-    Left msg | msg == Code.getResp -> return Nothing
-    Right (GetResponse RpbGetResp{..}) -> return . Just $ (content, VClock <$> vclock)
-    bad             -> fail $  "get: invalid response " ++ show bad
+  sendRequest conn RpbGetReq { bucket = bucket
+                             , key = key
+                             , r = fromQuorum <$> r }
+  maybe Nothing cast <$> recvMaybeResponse conn
+ where cast RpbGetResp{..} = 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
-  let req = RpbPutReq bucket key (fromVClock <$> vclock) content (fromQuorum <$> w) (fromQuorum <$> dw) (Just returnBody)
-  sendRequest conn req
-  resp <- recvResponse_ conn
-  case resp of
-    PutResponse RpbPutResp{..} -> return (content, VClock <$> vclock)
-    bad ->  fail $ "put: invalid response " ++ show bad
-
-setClientID :: Connection -> ClientID -> IO ()
-setClientID conn id = do
-  let req = RpbSetClientIdReq { client_id = id }
-  sendRequest conn req
-  resp <- recvResponse_ conn
-  unless (resp == SetClientIDResponse) .
-    fail $ "setClientID: invalid response " ++ show resp
+  sendRequest conn $ RpbPutReq bucket key (fromVClock <$> vclock) content
+                     (fromQuorum <$> w) (fromQuorum <$> dw) (Just returnBody)
+  RpbPutResp{..} <- recvResponse conn
+  return (content, VClock <$> vclock)

src/Network/Riak/Client.hs

-module Network.Riak.Client
-    (
-     )

src/Network/Riak/Content.hs

 
 module Network.Riak.Content
     (
-      unspecified
+      RpbContent(..)
+    , Content
+    , unspecified
     , binary
     ) where
 
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified Data.Sequence as Seq
-import Network.Riakclient.RpbContent
+import Network.Riakclient.RpbContent as Rpb
 import Network.Riak.Types
 
 unspecified :: Content

src/Network/Riak/Message.hs

-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ExistentialQuantification, RecordWildCards #-}
 
 module Network.Riak.Message
     (
-      Response(..)
-    , getResponse
+      getResponse
     , putPingReq
     , recvResponse_
     , recvResponse
+    , recvMaybeResponse
     , sendRequest
     ) where
 
+import Control.Monad
 import Data.Binary hiding (Get)
 import Data.Binary.Put
 import Data.ByteString.Lazy as L
 import Network.Socket
 import Network.Riak.Socket
 import Network.Riak.Types
-import Network.Riak.Message.Code
+import Network.Riak.Types.Internal
+import Network.Riak.Message.Tag
 import Text.ProtocolBuffers as PB
 import Text.ProtocolBuffers.Get
 import Network.Riakclient.RpbGetResp
 import Network.Riakclient.RpbPutResp
+import Network.Riakclient.RpbGetClientIdResp
 import Network.Socket.ByteString.Lazy as L
 
+putPingReq :: Put
+putPingReq = putWord32be 1 >> putTag PingReq
 
-data Response = ErrorResponse
-              | PingResponse
-              | SetClientIDResponse
-              | GetResponse RpbGetResp
-              | PutResponse RpbPutResp
-                deriving (Eq, Show)
-
-putPingReq :: Put
-putPingReq = putWord32be 1 >> putCode pingReq
-
-putRequest :: (Coded req, ReflectDescriptor req, Wire req) => req -> Put
+putRequest :: (Request req) => req -> Put
 putRequest req = do
   putWord32be (fromIntegral (1 + messageSize req))
-  putCode (messageCode req)
+  putTag (messageTag req)
   messagePutM req
 
-sendRequest :: (Coded req, ReflectDescriptor req, Wire req) =>
-               Connection -> req -> IO ()
+sendRequest :: (Request req) => Connection -> req -> IO ()
 sendRequest Connection{..} req = L.sendAll connSock . runPut . putRequest $ req
 
-getterMap :: Map.IntMap (Get Response)
-getterMap = Map.fromList [
-              errorResp -:> return ErrorResponse
-            , pingResp -:> return PingResponse
-            , getResp -:> (GetResponse `fmap` messageGetM)
-            , putResp -:> (PutResponse `fmap` messageGetM)
-            , setClientIdResp -:> return SetClientIDResponse
-            ]
-  where a -:> b = (messageNumber a, b)
+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
 
-getResponse :: Get Response
-getResponse = do
-  code <- getCode
-  Map.findWithDefault (fail $ "invalid response: " ++ show code)
-         (messageNumber code) getterMap
+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 -> IO Response
-recvResponse_ conn = do
+recvResponse_ :: Connection -> MessageTag -> IO ()
+recvResponse_ conn expected = do
   len <- fromIntegral `fmap` recvGet conn getWord32be
-  recvGetN conn len getResponse
+  tag <- recvGet conn getTag
+  when (tag /= expected) .
+    fail $ "received unexpected response: expected " ++
+           show expected ++ ", received " ++ show tag
+  recvExactly conn (len-1) >> return ()
 
-recvResponse :: Connection -> IO (Either MessageCode Response)
-recvResponse conn = do
-  len <- fromIntegral `fmap` recvGet conn getWord32be
-  print len
-  if len == 1
-    then Left `fmap` recvGet conn getCode
-    else Right `fmap` recvGetN conn len getResponse
+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/Code.hs

-module Network.Riak.Message.Code
-    (
-      Coded(..)
-    , MessageCode
-    , messageNumber
-    , getCode
-    , putCode
-    , errorResp
-    , pingReq
-    , pingResp
-    , getClientIdReq
-    , getClientIdResp
-    , setClientIdReq
-    , setClientIdResp
-    , getServerInfoReq
-    , getServerInfoResp
-    , getReq 
-    , getResp
-    , putReq 
-    , putResp
-    , delReq 
-    , delResp
-    , listBucketsReq
-    , listBucketsResp
-    , listKeysReq
-    , listKeysResp
-    , getBucketReq
-    , getBucketResp
-    , setBucketReq
-    , setBucketResp
-    , mapRedReq
-    , mapRedResp
-    ) where
-
-import Control.Monad (liftM)
-import Data.Word (Word8)
-import Data.Binary.Put
-import Network.Riakclient.RpbSetClientIdReq
-import Network.Riakclient.RpbGetReq
-import Network.Riakclient.RpbPutReq
-import Text.ProtocolBuffers
-import Text.ProtocolBuffers.Get
-
-newtype MessageCode = M Word8
-    deriving (Eq)
-
-messageNumber :: MessageCode -> Int
-messageNumber (M m) = fromIntegral m
-{-# INLINE messageNumber #-}
-
-class Coded msg where
-    messageCode :: msg -> MessageCode
-
-instance Coded MessageCode where
-    messageCode m = m
-    {-# INLINE messageCode #-}
-
-instance Coded RpbSetClientIdReq where
-    messageCode _ = setClientIdReq
-    {-# INLINE messageCode #-}
-
-instance Coded RpbGetReq where
-    messageCode _ = getReq
-    {-# INLINE messageCode #-}
-
-instance Coded RpbPutReq where
-    messageCode _ = putReq
-    {-# INLINE messageCode #-}
-
-putCode :: MessageCode -> Put
-putCode (M m) = putWord8 m
-{-# INLINE putCode #-}
-
-getCode :: Get MessageCode
-getCode = do
-  n <- getWord8
-  if n > 24
-    then fail $ "invalid riak message code: " ++ show n
-    else return (M n)
-{-# INLINE getCode #-}
-
-instance Show MessageCode where
-    show (M 0) = "errorResp"
-    show (M 1) = "pingReq"
-    show (M 2) = "pingResp"
-    show (M 3) = "getClientIdReq"
-    show (M 4) = "getClientIdResp"
-    show (M 5) = "setClientIdReq"
-    show (M 6) = "setClientIdResp"
-    show (M 7) = "getServerInfoReq"
-    show (M 8) = "getServerInfoResp"
-    show (M 9) = "getReq"
-    show (M 10) = "getResp"
-    show (M 11) = "putReq"
-    show (M 12) = "putResp"
-    show (M 13) = "delReq"
-    show (M 14) = "delResp"
-    show (M 15) = "listBucketsReq"
-    show (M 16) = "listBucketsResp"
-    show (M 17) = "listKeysReq"
-    show (M 18) = "listKeysResp"
-    show (M 19) = "getBucketReq"
-    show (M 20) = "getBucketResp"
-    show (M 21) = "setBucketReq"
-    show (M 22) = "setBucketResp"
-    show (M 23) = "mapRedReq"
-    show (M 24) = "mapRedResp"
-
-errorResp :: MessageCode
-errorResp = M 0
-{-# INLINE errorResp #-}
-
-pingReq :: MessageCode
-pingReq = M 1
-{-# INLINE pingReq #-}
-
-pingResp :: MessageCode
-pingResp = M 2
-{-# INLINE pingResp #-}
-
-getClientIdReq :: MessageCode
-getClientIdReq = M 3
-{-# INLINE getClientIdReq #-}
-
-getClientIdResp :: MessageCode
-getClientIdResp = M 4
-{-# INLINE getClientIdResp #-}
-
-setClientIdReq :: MessageCode
-setClientIdReq = M 5
-{-# INLINE setClientIdReq #-}
-
-setClientIdResp :: MessageCode
-setClientIdResp = M 6
-{-# INLINE setClientIdResp #-}
-
-getServerInfoReq :: MessageCode
-getServerInfoReq = M 7
-{-# INLINE getServerInfoReq #-}
-
-getServerInfoResp :: MessageCode
-getServerInfoResp = M 8
-{-# INLINE getServerInfoResp #-}
-
-getReq  :: MessageCode
-getReq  = M 9
-{-# INLINE getReq  #-}
-
-getResp :: MessageCode
-getResp = M 10
-{-# INLINE getResp #-}
-
-putReq  :: MessageCode
-putReq  = M 11
-{-# INLINE putReq  #-}
-
-putResp :: MessageCode
-putResp = M 12
-{-# INLINE putResp #-}
-
-delReq  :: MessageCode
-delReq  = M 13
-{-# INLINE delReq  #-}
-
-delResp :: MessageCode
-delResp = M 14
-{-# INLINE delResp #-}
-
-listBucketsReq :: MessageCode
-listBucketsReq = M 15
-{-# INLINE listBucketsReq #-}
-
-listBucketsResp :: MessageCode
-listBucketsResp = M 16
-{-# INLINE listBucketsResp #-}
-
-listKeysReq :: MessageCode
-listKeysReq = M 17
-{-# INLINE listKeysReq #-}
-
-listKeysResp :: MessageCode
-listKeysResp = M 18
-{-# INLINE listKeysResp #-}
-
-getBucketReq :: MessageCode
-getBucketReq = M 19
-{-# INLINE getBucketReq #-}
-
-getBucketResp :: MessageCode
-getBucketResp = M 20
-{-# INLINE getBucketResp #-}
-
-setBucketReq :: MessageCode
-setBucketReq = M 21
-{-# INLINE setBucketReq #-}
-
-setBucketResp :: MessageCode
-setBucketResp = M 22
-{-# INLINE setBucketResp #-}
-
-mapRedReq :: MessageCode
-mapRedReq = M 23
-{-# INLINE mapRedReq #-}
-
-mapRedResp :: MessageCode
-mapRedResp = M 24
-{-# INLINE mapRedResp #-}

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.Riakclient.RpbSetClientIdReq
+import Network.Riakextra.RpbPingResp
+import Network.Riakclient.RpbGetReq
+import Network.Riakclient.RpbGetResp
+import Network.Riakclient.RpbPutReq
+import Network.Riakclient.RpbPutResp
+import Network.Riakclient.RpbDelReq
+import Network.Riakclient.RpbGetClientIdResp
+import Network.Riakclient.RpbGetServerInfoResp
+import Network.Riakextra.RpbSetClientIdResp
+import Network.Riakextra.RpbGetServerInfoReq
+import Network.Riakclient.RpbListKeysReq
+import Network.Riakclient.RpbGetBucketReq
+import Network.Riakclient.RpbSetBucketReq
+import Network.Riakclient.RpbMapRedReq
+import Network.Riakextra.RpbPingReq
+import Network.Riakextra.RpbGetClientIdReq
+import Text.ProtocolBuffers
+import Text.ProtocolBuffers.Get
+import Network.Riak.Types.Internal as Types
+
+instance Tagged RpbPingReq where
+    messageTag _ = PingReq
+    {-# INLINE messageTag #-}
+
+instance Request RpbPingReq
+
+instance Tagged RpbPingResp where
+    messageTag _ = PingResp
+    {-# INLINE messageTag #-}
+
+instance Response RpbPingResp
+
+instance Tagged RpbGetClientIdReq where
+    messageTag _ = GetClientIdReq
+    {-# INLINE messageTag #-}
+
+instance Request RpbGetClientIdReq
+
+instance Tagged RpbGetClientIdResp where
+    messageTag _ = GetClientIdResp
+    {-# INLINE messageTag #-}
+
+instance Response RpbGetClientIdResp
+
+instance Tagged RpbSetClientIdReq where
+    messageTag _ = SetClientIdReq
+    {-# INLINE messageTag #-}
+
+instance Request RpbSetClientIdReq
+
+instance Tagged RpbGetServerInfoReq where
+    messageTag _ = GetServerInfoReq
+    {-# INLINE messageTag #-}
+
+instance Request RpbGetServerInfoReq
+
+instance Tagged RpbGetServerInfoResp where
+    messageTag _ = GetServerInfoResp
+    {-# INLINE messageTag #-}
+
+instance Response RpbGetServerInfoResp
+
+instance Tagged RpbGetReq where
+    messageTag _ = GetReq
+    {-# INLINE messageTag #-}
+
+instance Request RpbGetReq
+
+instance Tagged RpbGetResp where
+    messageTag _ = GetResp
+    {-# INLINE messageTag #-}
+
+instance Response RpbGetResp
+
+instance Tagged RpbPutReq where
+    messageTag _ = PutReq
+    {-# INLINE messageTag #-}
+
+instance Request RpbPutReq
+
+instance Tagged RpbPutResp where
+    messageTag _ = PutResp
+    {-# INLINE messageTag #-}
+
+instance Response RpbPutResp
+
+instance Tagged RpbDelReq where
+    messageTag _ = DelReq
+    {-# INLINE messageTag #-}
+
+instance Request RpbDelReq
+
+instance Tagged RpbListKeysReq where
+    messageTag _ = ListKeysReq
+    {-# INLINE messageTag #-}
+
+instance Request RpbListKeysReq
+
+instance Tagged RpbGetBucketReq where
+    messageTag _ = GetBucketReq
+    {-# INLINE messageTag #-}
+
+instance Request RpbGetBucketReq
+
+instance Tagged RpbSetBucketReq where
+    messageTag _ = SetBucketReq
+    {-# INLINE messageTag #-}
+
+instance Request RpbSetBucketReq
+
+instance Tagged RpbMapRedReq where
+    messageTag _ = MapRedReq
+    {-# INLINE messageTag #-}
+
+instance Request RpbMapRedReq
+
+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/Socket.hs

 
 module Network.Riak.Socket
     (
-      recvExactly_
-    , recvExactly
+      recvExactly
     , recvGet
     , recvGetN
     ) where
         then onError (L.fromChunks (reverse acc))
         else go (bs:acc) (n' - fromIntegral len)
 
-recvExactly_ :: Connection -> Int64 -> IO L.ByteString
-recvExactly_ = recvWith return
-
 recvExactly :: Connection -> Int64 -> IO L.ByteString
 recvExactly = recvWith (const (fail "short read from network"))
 

src/Network/Riak/Types.hs

       ClientID
     , Client(..)
     , Content
+    , ServerInfo
     , Connection(..)
     , Bucket
     , Key
-    , Quorum
     , Q(..)
     , RW(..)
     , R(..)
     , W(..)
     , DW(..)
     , VClock
-    , fromQuorum
-    , toQuorum
     ) where
 
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
 import Data.IORef (IORef)
 import Network.Socket
-import Data.Word
 import Network.Riakclient.RpbContent
+import Network.Riakclient.RpbGetServerInfoResp
 import Network.Riak.Types.Internal
     
 type ClientID = L.ByteString
 
 data Client = Client {
-      riakHost :: HostName
-    , riakPort :: ServiceName
-    , riakPrefix :: B.ByteString
-    , riakMapReducePrefix :: B.ByteString
-    , riakClientID :: ClientID
+      host :: HostName
+    , port :: ServiceName
+    , prefix :: B.ByteString
+    , mapReducePrefix :: B.ByteString
+    , clientID :: ClientID
     } deriving (Eq, Show)
 
 data Connection = Connection {
     } deriving (Eq)
 
 instance Show Connection where
-    show conn = show "Connection " ++ riakHost c ++ ":" ++ riakPort c
+    show conn = show "Connection " ++ host c ++ ":" ++ port c
         where c = connClient conn
 
 type Bucket = L.ByteString
 
 type Key = L.ByteString
 
-data Q = 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 Content = RpbContent
 
-fromQ :: Q -> Word32
-fromQ Default = 4294967291
-fromQ All     = 4294967292
-fromQ Quorum  = 4294967293
-fromQ One     = 4294967294
-{-# INLINE fromQ #-}
-
-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 #-}
+type ServerInfo = RpbGetServerInfoResp

src/Network/Riak/Types/Internal.hs

 module Network.Riak.Types.Internal
     (
-     VClock(..)
+      MessageTag(..)
+    , Tagged(..)
+    , Request(..)
+    , Response(..)
+    , VClock(..)
+    , Q(..)
+    , RW(..)
+    , R(..)
+    , W(..)
+    , DW(..)
+    , fromQuorum
+    , toQuorum
     ) where
 
 import qualified Data.ByteString.Lazy as L
 import Data.Digest.Pure.MD5 (md5)
+import Data.Word
+import Text.ProtocolBuffers
+
+data MessageTag = ErrorResp
+                | PingReq
+                | PingResp
+                | GetClientIdReq
+                | GetClientIdResp
+                | SetClientIdReq
+                | SetClientIdResp
+                | GetServerInfoReq
+                | GetServerInfoResp
+                | GetReq
+                | GetResp
+                | PutReq
+                | PutResp
+                | DelReq
+                | DelResp
+                | ListBucketsReq
+                | ListBucketsResp
+                | ListKeysReq
+                | ListKeysResp
+                | GetBucketReq
+                | GetBucketResp
+                | SetBucketReq
+                | SetBucketResp
+                | MapRedReq
+                | MapRedResp
+                  deriving (Eq, Show, Enum)
+
+class Tagged msg where
+    messageTag :: msg -> MessageTag
+
+instance Tagged MessageTag where
+    messageTag m = m
+    {-# INLINE messageTag #-}
+
+class (Tagged msg, ReflectDescriptor msg, Wire msg) => Request msg
+
+class (Tagged msg, ReflectDescriptor msg, Wire msg) => Response msg
+
+instance (Tagged a, Tagged b) => Tagged (Either a b) where
+    messageTag (Left l)  = messageTag l
+    messageTag (Right r) = messageTag r
+    {-# INLINE messageTag #-}
 
 newtype VClock = VClock {
       fromVClock :: L.ByteString
 
 instance Show VClock where
     show (VClock s) = "VClock " ++ show (md5 s)
+
+data Q = 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)
+
+fromQ :: Q -> Word32
+fromQ Default = 4294967291
+fromQ All     = 4294967292
+fromQ Quorum  = 4294967293
+fromQ One     = 4294967294
+{-# INLINE fromQ #-}
+
+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 #-}

src/Network/Riakextra.hs

+module Network.Riakextra (protoInfo, fileDescriptorProto) where
+import Prelude ((+))
+import qualified Prelude as P'
+import qualified Text.ProtocolBuffers.Header as P'
+import Text.DescriptorProtos.FileDescriptorProto (FileDescriptorProto)
+import Text.ProtocolBuffers.Reflections (ProtoInfo)
+import qualified Text.ProtocolBuffers.WireMessage as P' (wireGet,getFromBS)
+ 
+protoInfo :: ProtoInfo
+protoInfo
+ = P'.read
+    "ProtoInfo {protoMod = ProtoName {protobufName = FIName \".Riakextra\", haskellPrefix = [MName \"Network\"], parentModule = [], baseName = MName \"Riakextra\"}, protoFilePath = [\"Network\",\"Riakextra.hs\"], protoSource = \"riakextra.proto\", extensionKeys = fromList [], messages = [DescriptorInfo {descName = ProtoName {protobufName = FIName \".Riakextra.RpbPingReq\", haskellPrefix = [MName \"Network\"], parentModule = [MName \"Riakextra\"], baseName = MName \"RpbPingReq\"}, descFilePath = [\"Network\",\"Riakextra\",\"RpbPingReq.hs\"], isGroup = False, fields = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".Riakextra.RpbPingResp\", haskellPrefix = [MName \"Network\"], parentModule = [MName \"Riakextra\"], baseName = MName \"RpbPingResp\"}, descFilePath = [\"Network\",\"Riakextra\",\"RpbPingResp.hs\"], isGroup = False, fields = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".Riakextra.RpbGetClientIdReq\", haskellPrefix = [MName \"Network\"], parentModule = [MName \"Riakextra\"], baseName = MName \"RpbGetClientIdReq\"}, descFilePath = [\"Network\",\"Riakextra\",\"RpbGetClientIdReq.hs\"], isGroup = False, fields = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".Riakextra.RpbSetClientIdResp\", haskellPrefix = [MName \"Network\"], parentModule = [MName \"Riakextra\"], baseName = MName \"RpbSetClientIdResp\"}, descFilePath = [\"Network\",\"Riakextra\",\"RpbSetClientIdResp.hs\"], isGroup = False, fields = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".Riakextra.RpbGetServerInfoReq\", haskellPrefix = [MName \"Network\"], parentModule = [MName \"Riakextra\"], baseName = MName \"RpbGetServerInfoReq\"}, descFilePath = [\"Network\",\"Riakextra\",\"RpbGetServerInfoReq.hs\"], isGroup = False, fields = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False}], enums = [], knownKeyMap = fromList []}"
+ 
+fileDescriptorProto :: FileDescriptorProto
+fileDescriptorProto
+ = P'.getFromBS (P'.wireGet 11)
+    (P'.pack
+      "p\n\SIriakextra.proto\"\f\n\nRpbPingReq\"\r\n\vRpbPingResp\"\DC3\n\DC1RpbGetClientIdReq\"\DC4\n\DC2RpbSetClientIdResp\"\NAK\n\DC3RpbGetServerInfoReq")

src/Network/Riakextra/RpbGetClientIdReq.hs

+module Network.Riakextra.RpbGetClientIdReq (RpbGetClientIdReq(..)) where
+import Prelude ((+))
+import qualified Prelude as P'
+import qualified Text.ProtocolBuffers.Header as P'
+ 
+data RpbGetClientIdReq = RpbGetClientIdReq{}
+                       deriving (P'.Show, P'.Eq, P'.Ord, P'.Typeable)
+ 
+instance P'.Mergeable RpbGetClientIdReq where
+  mergeEmpty = RpbGetClientIdReq
+  mergeAppend (RpbGetClientIdReq) (RpbGetClientIdReq) = RpbGetClientIdReq
+ 
+instance P'.Default RpbGetClientIdReq where
+  defaultValue = RpbGetClientIdReq
+ 
+instance P'.Wire RpbGetClientIdReq where
+  wireSize ft' self'@(RpbGetClientIdReq)
+   = case ft' of
+       10 -> calc'Size
+       11 -> P'.prependMessageSize calc'Size
+       _ -> P'.wireSizeErr ft' self'
+    where
+        calc'Size = 0
+  wirePut ft' self'@(RpbGetClientIdReq)
+   = case ft' of
+       10 -> put'Fields
+       11 -> do
+               P'.putSize (P'.wireSize 10 self')
+               put'Fields
+       _ -> P'.wirePutErr ft' self'
+    where
+        put'Fields
+         = do
+             P'.return ()
+  wireGet ft'
+   = case ft' of
+       10 -> P'.getBareMessageWith update'Self
+       11 -> P'.getMessageWith update'Self
+       _ -> P'.wireGetErr ft'
+    where
+        update'Self wire'Tag old'Self
+         = case wire'Tag of
+             _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self
+ 
+instance P'.MessageAPI msg' (msg' -> RpbGetClientIdReq) RpbGetClientIdReq where
+  getVal m' f' = f' m'
+ 
+instance P'.GPB RpbGetClientIdReq
+ 
+instance P'.ReflectDescriptor RpbGetClientIdReq where
+  getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [])
+  reflectDescriptorInfo _
+   = P'.read
+      "DescriptorInfo {descName = ProtoName {protobufName = FIName \".Riakextra.RpbGetClientIdReq\", haskellPrefix = [MName \"Network\"], parentModule = [MName \"Riakextra\"], baseName = MName \"RpbGetClientIdReq\"}, descFilePath = [\"Network\",\"Riakextra\",\"RpbGetClientIdReq.hs\"], isGroup = False, fields = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False}"

src/Network/Riakextra/RpbGetServerInfoReq.hs

+module Network.Riakextra.RpbGetServerInfoReq (RpbGetServerInfoReq(..)) where
+import Prelude ((+))
+import qualified Prelude as P'
+import qualified Text.ProtocolBuffers.Header as P'
+ 
+data RpbGetServerInfoReq = RpbGetServerInfoReq{}
+                         deriving (P'.Show, P'.Eq, P'.Ord, P'.Typeable)
+ 
+instance P'.Mergeable RpbGetServerInfoReq where
+  mergeEmpty = RpbGetServerInfoReq
+  mergeAppend (RpbGetServerInfoReq) (RpbGetServerInfoReq) = RpbGetServerInfoReq
+ 
+instance P'.Default RpbGetServerInfoReq where
+  defaultValue = RpbGetServerInfoReq
+ 
+instance P'.Wire RpbGetServerInfoReq where
+  wireSize ft' self'@(RpbGetServerInfoReq)
+   = case ft' of
+       10 -> calc'Size
+       11 -> P'.prependMessageSize calc'Size
+       _ -> P'.wireSizeErr ft' self'
+    where
+        calc'Size = 0
+  wirePut ft' self'@(RpbGetServerInfoReq)
+   = case ft' of
+       10 -> put'Fields
+       11 -> do
+               P'.putSize (P'.wireSize 10 self')
+               put'Fields
+       _ -> P'.wirePutErr ft' self'
+    where
+        put'Fields
+         = do
+             P'.return ()
+  wireGet ft'
+   = case ft' of
+       10 -> P'.getBareMessageWith update'Self
+       11 -> P'.getMessageWith update'Self
+       _ -> P'.wireGetErr ft'
+    where
+        update'Self wire'Tag old'Self
+         = case wire'Tag of
+             _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self
+ 
+instance P'.MessageAPI msg' (msg' -> RpbGetServerInfoReq) RpbGetServerInfoReq where
+  getVal m' f' = f' m'
+ 
+instance P'.GPB RpbGetServerInfoReq
+ 
+instance P'.ReflectDescriptor RpbGetServerInfoReq where
+  getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [])
+  reflectDescriptorInfo _
+   = P'.read
+      "DescriptorInfo {descName = ProtoName {protobufName = FIName \".Riakextra.RpbGetServerInfoReq\", haskellPrefix = [MName \"Network\"], parentModule = [MName \"Riakextra\"], baseName = MName \"RpbGetServerInfoReq\"}, descFilePath = [\"Network\",\"Riakextra\",\"RpbGetServerInfoReq.hs\"], isGroup = False, fields = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False}"

src/Network/Riakextra/RpbPingReq.hs

+module Network.Riakextra.RpbPingReq (RpbPingReq(..)) where
+import Prelude ((+))
+import qualified Prelude as P'
+import qualified Text.ProtocolBuffers.Header as P'
+ 
+data RpbPingReq = RpbPingReq{}
+                deriving (P'.Show, P'.Eq, P'.Ord, P'.Typeable)
+ 
+instance P'.Mergeable RpbPingReq where
+  mergeEmpty = RpbPingReq
+  mergeAppend (RpbPingReq) (RpbPingReq) = RpbPingReq
+ 
+instance P'.Default RpbPingReq where
+  defaultValue = RpbPingReq
+ 
+instance P'.Wire RpbPingReq where
+  wireSize ft' self'@(RpbPingReq)
+   = case ft' of
+       10 -> calc'Size
+       11 -> P'.prependMessageSize calc'Size
+       _ -> P'.wireSizeErr ft' self'
+    where
+        calc'Size = 0
+  wirePut ft' self'@(RpbPingReq)
+   = case ft' of
+       10 -> put'Fields
+       11 -> do
+               P'.putSize (P'.wireSize 10 self')
+               put'Fields
+       _ -> P'.wirePutErr ft' self'
+    where
+        put'Fields
+         = do
+             P'.return ()
+  wireGet ft'
+   = case ft' of
+       10 -> P'.getBareMessageWith update'Self
+       11 -> P'.getMessageWith update'Self
+       _ -> P'.wireGetErr ft'
+    where
+        update'Self wire'Tag old'Self
+         = case wire'Tag of
+             _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self
+ 
+instance P'.MessageAPI msg' (msg' -> RpbPingReq) RpbPingReq where
+  getVal m' f' = f' m'
+ 
+instance P'.GPB RpbPingReq
+ 
+instance P'.ReflectDescriptor RpbPingReq where
+  getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [])
+  reflectDescriptorInfo _
+   = P'.read
+      "DescriptorInfo {descName = ProtoName {protobufName = FIName \".Riakextra.RpbPingReq\", haskellPrefix = [MName \"Network\"], parentModule = [MName \"Riakextra\"], baseName = MName \"RpbPingReq\"}, descFilePath = [\"Network\",\"Riakextra\",\"RpbPingReq.hs\"], isGroup = False, fields = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False}"

src/Network/Riakextra/RpbPingResp.hs

+module Network.Riakextra.RpbPingResp (RpbPingResp(..)) where
+import Prelude ((+))
+import qualified Prelude as P'
+import qualified Text.ProtocolBuffers.Header as P'
+ 
+data RpbPingResp = RpbPingResp{}
+                 deriving (P'.Show, P'.Eq, P'.Ord, P'.Typeable)
+ 
+instance P'.Mergeable RpbPingResp where
+  mergeEmpty = RpbPingResp
+  mergeAppend (RpbPingResp) (RpbPingResp) = RpbPingResp
+ 
+instance P'.Default RpbPingResp where
+  defaultValue = RpbPingResp
+ 
+instance P'.Wire RpbPingResp where
+  wireSize ft' self'@(RpbPingResp)
+   = case ft' of
+       10 -> calc'Size
+       11 -> P'.prependMessageSize calc'Size
+       _ -> P'.wireSizeErr ft' self'
+    where
+        calc'Size = 0
+  wirePut ft' self'@(RpbPingResp)
+   = case ft' of
+       10 -> put'Fields
+       11 -> do
+               P'.putSize (P'.wireSize 10 self')
+               put'Fields
+       _ -> P'.wirePutErr ft' self'
+    where
+        put'Fields
+         = do
+             P'.return ()
+  wireGet ft'
+   = case ft' of
+       10 -> P'.getBareMessageWith update'Self
+       11 -> P'.getMessageWith update'Self
+       _ -> P'.wireGetErr ft'
+    where
+        update'Self wire'Tag old'Self
+         = case wire'Tag of
+             _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self
+ 
+instance P'.MessageAPI msg' (msg' -> RpbPingResp) RpbPingResp where
+  getVal m' f' = f' m'
+ 
+instance P'.GPB RpbPingResp
+ 
+instance P'.ReflectDescriptor RpbPingResp where
+  getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [])
+  reflectDescriptorInfo _
+   = P'.read
+      "DescriptorInfo {descName = ProtoName {protobufName = FIName \".Riakextra.RpbPingResp\", haskellPrefix = [MName \"Network\"], parentModule = [MName \"Riakextra\"], baseName = MName \"RpbPingResp\"}, descFilePath = [\"Network\",\"Riakextra\",\"RpbPingResp.hs\"], isGroup = False, fields = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False}"

src/Network/Riakextra/RpbSetClientIdResp.hs

+module Network.Riakextra.RpbSetClientIdResp (RpbSetClientIdResp(..)) where
+import Prelude ((+))
+import qualified Prelude as P'
+import qualified Text.ProtocolBuffers.Header as P'
+ 
+data RpbSetClientIdResp = RpbSetClientIdResp{}
+                        deriving (P'.Show, P'.Eq, P'.Ord, P'.Typeable)
+ 
+instance P'.Mergeable RpbSetClientIdResp where
+  mergeEmpty = RpbSetClientIdResp
+  mergeAppend (RpbSetClientIdResp) (RpbSetClientIdResp) = RpbSetClientIdResp
+ 
+instance P'.Default RpbSetClientIdResp where
+  defaultValue = RpbSetClientIdResp
+ 
+instance P'.Wire RpbSetClientIdResp where
+  wireSize ft' self'@(RpbSetClientIdResp)
+   = case ft' of
+       10 -> calc'Size
+       11 -> P'.prependMessageSize calc'Size
+       _ -> P'.wireSizeErr ft' self'
+    where
+        calc'Size = 0
+  wirePut ft' self'@(RpbSetClientIdResp)
+   = case ft' of
+       10 -> put'Fields
+       11 -> do
+               P'.putSize (P'.wireSize 10 self')
+               put'Fields
+       _ -> P'.wirePutErr ft' self'
+    where
+        put'Fields
+         = do
+             P'.return ()
+  wireGet ft'
+   = case ft' of
+       10 -> P'.getBareMessageWith update'Self
+       11 -> P'.getMessageWith update'Self
+       _ -> P'.wireGetErr ft'
+    where
+        update'Self wire'Tag old'Self
+         = case wire'Tag of
+             _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self
+ 
+instance P'.MessageAPI msg' (msg' -> RpbSetClientIdResp) RpbSetClientIdResp where
+  getVal m' f' = f' m'
+ 
+instance P'.GPB RpbSetClientIdResp
+ 
+instance P'.ReflectDescriptor RpbSetClientIdResp where
+  getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [])
+  reflectDescriptorInfo _
+   = P'.read
+      "DescriptorInfo {descName = ProtoName {protobufName = FIName \".Riakextra.RpbSetClientIdResp\", haskellPrefix = [MName \"Network\"], parentModule = [MName \"Riakextra\"], baseName = MName \"RpbSetClientIdResp\"}, descFilePath = [\"Network\",\"Riakextra\",\"RpbSetClientIdResp.hs\"], isGroup = False, fields = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False}"

src/riakextra.proto

+message RpbPingReq { }
+message RpbPingResp { }
+message RpbGetClientIdReq { }
+message RpbSetClientIdResp { }
+message RpbGetServerInfoReq { }
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.