Tag.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- Module:      Network.Riak.Content
-- Copyright:   (c) 2011 MailRank, Inc.
-- License:     Apache
-- Maintainer:  Mark Hibberd <mark@hibberd.id.au>, Nathan Hunter <nhunter@janrain.com>
-- Stability:   experimental
-- Portability: portable
--
-- im in ur msg system taggin ur msg types

module Network.Riak.Tag
    (
      putTag
    , getTag
    ) where

import Data.Binary.Get (Get, getWord8)
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.Riak.Proto
import Data.Tuple (swap)
import Network.Riak.Types.Internal as Types

instance Tagged RpbErrorResp where
    messageTag _ = Types.ErrorResponse
    {-# INLINE messageTag #-}

instance Response RpbErrorResp

instance Tagged RpbPingReq where
    messageTag _ = Types.PingRequest
    {-# INLINE messageTag #-}

instance Request RpbPingReq where
    expectedResponse _ = Types.PingResponse
    {-# INLINE expectedResponse #-}

instance Tagged RpbGetClientIdReq where
    messageTag _ = Types.GetClientIDRequest
    {-# INLINE messageTag #-}

instance Request RpbGetClientIdReq where
    expectedResponse _ = Types.GetClientIDResponse
    {-# INLINE expectedResponse #-}

instance Tagged RpbGetClientIdResp where
    messageTag _ = Types.GetClientIDResponse
    {-# INLINE messageTag #-}

instance Response RpbGetClientIdResp

instance Exchange RpbGetClientIdReq RpbGetClientIdResp

instance Tagged RpbSetClientIdReq where
    messageTag _ = Types.SetClientIDRequest
    {-# INLINE messageTag #-}

instance Request RpbSetClientIdReq where
    expectedResponse _ = Types.SetClientIDResponse
    {-# INLINE expectedResponse #-}

instance Tagged RpbGetServerInfoReq where
    messageTag _ = Types.GetServerInfoRequest
    {-# INLINE messageTag #-}

instance Request RpbGetServerInfoReq where
    expectedResponse _ = Types.GetServerInfoResponse
    {-# INLINE expectedResponse #-}

instance Tagged RpbGetServerInfoResp where
    messageTag _ = Types.GetServerInfoResponse
    {-# INLINE messageTag #-}

instance Response RpbGetServerInfoResp

instance Exchange RpbGetServerInfoReq RpbGetServerInfoResp

instance Tagged RpbGetReq where
    messageTag _ = Types.GetRequest
    {-# INLINE messageTag #-}

instance Tagged RpbIndexReq where
    messageTag _ = Types.IndexRequest
    {-# INLINE messageTag #-}

instance Request RpbGetReq where
    expectedResponse _ = Types.GetResponse
    {-# INLINE expectedResponse #-}

instance Request RpbIndexReq where
    expectedResponse _ = Types.IndexResponse
    {-# INLINE expectedResponse #-}

instance Tagged RpbGetResp where
    messageTag _ = Types.GetResponse
    {-# INLINE messageTag #-}

instance Tagged RpbIndexResp where
    messageTag _ = Types.IndexResponse
    {-# INLINE messageTag #-}

instance Response RpbGetResp

instance Response RpbIndexResp

instance Exchange RpbGetReq RpbGetResp

instance Exchange RpbIndexReq RpbIndexResp

instance Tagged RpbPutReq where
    messageTag _ = Types.PutRequest
    {-# INLINE messageTag #-}

instance Request RpbPutReq where
    expectedResponse _ = Types.PutResponse
    {-# INLINE expectedResponse #-}

instance Tagged RpbPutResp where
    messageTag _ = Types.PutResponse
    {-# INLINE messageTag #-}

instance Response RpbPutResp

instance Exchange RpbPutReq RpbPutResp

instance Tagged RpbDelReq where
    messageTag _ = Types.DeleteRequest
    {-# INLINE messageTag #-}

instance Request RpbDelReq where
    expectedResponse _ = Types.DeleteResponse
    {-# INLINE expectedResponse #-}

instance Tagged RpbListBucketsReq where
    messageTag _ = Types.ListBucketsRequest
    {-# INLINE messageTag #-}

instance Request RpbListBucketsReq where
    expectedResponse _ = Types.ListBucketsResponse
    {-# INLINE expectedResponse #-}

instance Tagged RpbListBucketsResp where
    messageTag _ = Types.ListBucketsResponse
    {-# INLINE messageTag #-}

instance Response RpbListBucketsResp

instance Exchange RpbListBucketsReq RpbListBucketsResp

instance Tagged RpbListKeysReq where
    messageTag _ = Types.ListKeysRequest
    {-# INLINE messageTag #-}

instance Request RpbListKeysReq where
    expectedResponse _ = Types.ListKeysResponse
    {-# INLINE expectedResponse #-}

instance Tagged RpbListKeysResp where
    messageTag _ = Types.ListKeysResponse
    {-# INLINE messageTag #-}

instance Response RpbListKeysResp

instance Tagged RpbGetBucketReq where
    messageTag _ = Types.GetBucketRequest
    {-# INLINE messageTag #-}

instance Request RpbGetBucketReq where
    expectedResponse _ = Types.GetBucketResponse
    {-# INLINE expectedResponse #-}

instance Tagged RpbGetBucketResp where
    messageTag _ = Types.GetBucketResponse
    {-# INLINE messageTag #-}

instance Response RpbGetBucketResp

instance Exchange RpbGetBucketReq RpbGetBucketResp

instance Tagged RpbSetBucketReq where
    messageTag _ = Types.SetBucketRequest
    {-# INLINE messageTag #-}

instance Request RpbSetBucketReq where
    expectedResponse _ = Types.SetBucketResponse
    {-# INLINE expectedResponse #-}

instance Request RpbGetBucketTypeReq where
    expectedResponse _ = Types.GetBucketResponse

instance Tagged RpbGetBucketTypeReq where
    messageTag _ = Types.GetBucketTypeRequest

instance Exchange RpbGetBucketTypeReq RpbGetBucketResp

instance Tagged RpbMapRedReq where
    messageTag _ = Types.MapReduceRequest
    {-# INLINE messageTag #-}

instance Request RpbMapRedReq where
    expectedResponse _ = Types.MapReduceResponse
    {-# INLINE expectedResponse #-}

instance Tagged RpbMapRedResp where
    messageTag _ = Types.MapReduceResponse
    {-# INLINE messageTag #-}


instance Response RpbMapRedResp

instance Exchange RpbMapRedReq RpbMapRedResp

instance Tagged DtFetchReq where
    messageTag _ = Types.DtFetchRequest
    {-# INLINE messageTag #-}

instance Tagged DtFetchResp where
    messageTag _ = Types.DtFetchResponse
    {-# INLINE messageTag #-}

instance Request DtFetchReq where
    expectedResponse _ = Types.DtFetchResponse
    {-# INLINE expectedResponse #-}

instance Response DtFetchResp

instance Exchange DtFetchReq DtFetchResp

instance Tagged DtUpdateReq where
    messageTag _ = Types.DtUpdateRequest
    {-# INLINE messageTag #-}

instance Tagged DtUpdateResp where
    messageTag _ = Types.DtUpdateResponse
    {-# INLINE messageTag #-}

instance Request DtUpdateReq where
    expectedResponse _ = Types.DtUpdateResponse
    {-# INLINE expectedResponse #-}

instance Response DtUpdateResp

instance Exchange DtUpdateReq DtUpdateResp

instance Tagged RpbSearchQueryReq where
    messageTag _ = Types.SearchQueryRequest
    {-# INLINE messageTag #-}

instance Request RpbSearchQueryReq where
    expectedResponse _ = Types.SearchQueryResponse
    {-# INLINE expectedResponse #-}

instance Tagged RpbSearchQueryResp where
    messageTag _ = Types.SearchQueryResponse
    {-# INLINE messageTag #-}

instance Response RpbSearchQueryResp

instance Exchange RpbSearchQueryReq RpbSearchQueryResp

instance Tagged RpbYokozunaIndexGetReq where
    messageTag _ = Types.YokozunaIndexGetRequest

instance Request RpbYokozunaIndexGetReq where
    expectedResponse _ = Types.YokozunaIndexGetResponse

instance Tagged RpbYokozunaIndexGetResp where
    messageTag _ = Types.YokozunaIndexGetResponse

instance Response RpbYokozunaIndexGetResp

instance Exchange RpbYokozunaIndexGetReq RpbYokozunaIndexGetResp

instance Request RpbYokozunaIndexPutReq where
  expectedResponse _ = Types.YokozunaIndexPutRequest

instance Tagged RpbYokozunaIndexPutReq where
  messageTag _ = Types.YokozunaIndexPutRequest

instance Exchange RpbYokozunaIndexPutReq RpbPutResp

instance Tagged RpbYokozunaIndexDeleteReq where
    messageTag _ = Types.YokozunaIndexDeleteRequest

instance Request RpbYokozunaIndexDeleteReq where
    expectedResponse _ = Types.DeleteResponse

putTag :: MessageTag -> Put
putTag m = putWord8 $ message2code HM.! m
{-# INLINE putTag #-}

getTag :: Get MessageTag
getTag = do
  n <- getWord8
  maybe (err n) pure $ HM.lookup n code2message
      where
        err n = moduleError "getTag" $ "invalid riak message code: " ++ show n
{-# INLINE getTag #-}

moduleError :: String -> String -> a
moduleError = netError "Network.Riak.Tag"


code2message :: HM.HashMap Word8 MessageTag
code2message = HM.fromList messageCodes

message2code :: HM.HashMap MessageTag Word8
message2code = HM.fromList . map swap $ messageCodes

messageCodes :: [(Word8, MessageTag)]
messageCodes = [
 -- From riak-2.1.3/deps/riak_pb/src/riak_pb_messages.csv
 --
 -- This is a list of all known riak messages (with appropriate
 -- message codes).  Most of them are described at
 -- http://docs.basho.com/riak/2.1.3/dev/references/protocol-buffers/
 --
 -- Commented ones are messages we don't use/support yet.
 (0, Types.ErrorResponse),
 (1, Types.PingRequest),
 (2, Types.PingResponse),
 (3, Types.GetClientIDResponse),
 (4, Types.GetClientIDResponse),
 (5, Types.SetClientIDRequest),
 (6, Types.SetClientIDResponse),
 (7, Types.GetServerInfoRequest),
 (8, Types.GetServerInfoResponse),
 (9, Types.GetRequest),
 (10, Types.GetResponse),
 (11, Types.PutRequest),
 (12, Types.PutResponse),
 (13, Types.DeleteRequest),
 (14, Types.DeleteResponse),
 (15, Types.ListBucketsRequest),
 (16, Types.ListBucketsResponse),
 (17, Types.ListKeysRequest),
 (18, Types.ListKeysResponse),
 (19, Types.GetBucketRequest),
 (20, Types.GetBucketResponse),
 (21, Types.SetBucketRequest),
 (22, Types.SetBucketResponse),
 (23, Types.MapReduceRequest),
 (24, Types.MapReduceResponse),
 (25, Types.IndexRequest),
 (26, Types.IndexResponse),
 (27, Types.SearchQueryRequest),
 (28, Types.SearchQueryResponse),
 -- (29,ResetBucketRequest),
 -- (30,ResetBucketResp),
 (31, Types.GetBucketTypeRequest),
 -- (32,SetBucketTypeReq),
 -- (33,GetBucketKeyPreflistReq),
 -- (34,GetBucketKeyPreflistResp),
 -- (40,CSBucketReq),
 -- (41,CSBucketResp),
 -- (50,CounterUpdateReq),
 -- (51,CounterUpdateResp),
 -- (52,CounterGetReq),
 -- (53,CounterGetResp),
 (54, Types.YokozunaIndexGetRequest),
 (55, Types.YokozunaIndexGetResponse),
 (56, Types.YokozunaIndexPutRequest),
 (57, Types.YokozunaIndexDeleteRequest),
 -- (58,YokozunaSchemaGetReq),
 -- (59,YokozunaSchemaGetResp),
 -- (60,YokozunaSchemaPutReq),
 (80, Types.DtFetchRequest),
 (81, Types.DtFetchResponse),
 (82, Types.DtUpdateRequest),
 (83, Types.DtUpdateResponse)
 -- (253,RpbAuthReq),
 -- (254,RpbAuthResp),
 -- (255,RpbStartTls)
 ]