module Network.WebSockets.RPC.Types
( RPCID, getRPCID
,
RPCIdentified (..), Subscribe (Subscribe), Supply (..), Reply (Reply), Complete (Complete)
,
ClientToServer (..), ServerToClient (..)
,
WebSocketRPCException (..)
) where
import Data.Data (Data, Typeable)
import GHC.Generics (Generic)
import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=), object)
import Data.Aeson.Types (typeMismatch, Value (Object, String), Parser)
import qualified Data.HashMap.Lazy as HM
import Data.Text (Text)
import Data.ByteString.Lazy (ByteString)
import Control.Applicative ((<|>))
import Control.Monad.Catch (Exception)
import Test.QuickCheck (Arbitrary (..), CoArbitrary)
newtype RPCID = RPCID {getRPCID :: Int}
deriving (Show, Read, Num, Eq, Ord, Enum, Bounded, Generic, Data, Typeable, FromJSON, ToJSON, Arbitrary, CoArbitrary)
data RPCIdentified a = RPCIdentified
{ _ident :: !RPCID
, _params :: !a
} deriving (Show, Read, Eq, Generic, Data, Typeable)
instance ToJSON a => ToJSON (RPCIdentified a) where
toJSON RPCIdentified {_ident,_params} = object
[ "ident" .= _ident
, "params" .= _params
]
instance FromJSON a => FromJSON (RPCIdentified a) where
parseJSON (Object o) = RPCIdentified <$> o .: "ident" <*> o .: "params"
parseJSON x = typeMismatch "RPCIdentified" x
instance Arbitrary a => Arbitrary (RPCIdentified a) where
arbitrary = RPCIdentified <$> arbitrary <*> arbitrary
shrink RPCIdentified{_ident,_params} = RPCIdentified <$> shrink _ident <*> shrink _params
newtype Subscribe a = Subscribe {getSubscribe :: RPCIdentified a}
deriving (Show, Read, Eq, Generic, Data, Typeable, Arbitrary)
instance ToJSON a => ToJSON (Subscribe a) where
toJSON (Subscribe x) = case toJSON x of
Object xs -> Object (HM.insert "type" (String "sub") xs)
_ -> error "inconceivable!"
instance FromJSON a => FromJSON (Subscribe a) where
parseJSON x@(Object o) = do
t <- o .: "type"
if t == ("sub" :: Text)
then Subscribe <$> parseJSON x
else fail "Not a subscription"
parseJSON x = typeMismatch "Subscribe" x
newtype Supply a = Supply { getSupply :: RPCIdentified (Maybe a) }
deriving (Show, Read, Eq, Generic, Data, Typeable, Arbitrary)
instance ToJSON a => ToJSON (Supply a) where
toJSON Supply {getSupply} = case toJSON getSupply of
Object xs -> Object (HM.insert "type" (String "sup") xs)
_ -> error "inconceivable!"
instance FromJSON a => FromJSON (Supply a) where
parseJSON x@(Object o) = do
t <- o .: "type"
if t == ("sup" :: Text)
then Supply <$> parseJSON x
else fail "Not a supply"
parseJSON x = typeMismatch "Supply" x
newtype Reply a = Reply {getReply :: RPCIdentified a}
deriving (Show, Read, Eq, Generic, Data, Typeable, Arbitrary)
instance ToJSON a => ToJSON (Reply a) where
toJSON (Reply x) = case toJSON x of
Object xs -> Object (HM.insert "type" (String "rep") xs)
_ -> error "inconceivable!"
instance FromJSON a => FromJSON (Reply a) where
parseJSON x@(Object o) = do
t <- o .: "type"
if t == ("rep" :: Text)
then Reply <$> parseJSON x
else fail "Not a reply"
parseJSON x = typeMismatch "Reply" x
newtype Complete a = Complete {getComplete :: RPCIdentified a}
deriving (Show, Read, Eq, Generic, Data, Typeable, Arbitrary)
instance ToJSON a => ToJSON (Complete a) where
toJSON (Complete x) = case toJSON x of
Object xs -> Object (HM.insert "type" (String "com") xs)
_ -> error "inconceivable!"
instance FromJSON a => FromJSON (Complete a) where
parseJSON x@(Object o) = do
t <- o .: "type"
if t == ("com" :: Text)
then Complete <$> parseJSON x
else fail "Not a complete"
parseJSON x = typeMismatch "Complete" x
data ClientToServer sub sup
= Sub (Subscribe sub)
| Sup (Supply sup)
| Ping
deriving (Show, Read, Eq, Generic, Data, Typeable)
instance (Arbitrary sub, Arbitrary sup) => Arbitrary (ClientToServer sub sup) where
arbitrary = do
(q,p) <- arbitrary
if q
then Sub <$> arbitrary
else if p
then Sup <$> arbitrary
else pure Ping
instance (ToJSON sub, ToJSON sup) => ToJSON (ClientToServer sub sup) where
toJSON (Sub x) = toJSON x
toJSON (Sup x) = toJSON x
toJSON Ping = toJSON ([] :: [()])
instance (FromJSON sub, FromJSON sup) => FromJSON (ClientToServer sub sup) where
parseJSON x
= (Sub <$> parseJSON x)
<|> (Sup <$> parseJSON x)
<|> (Ping <$ (parseJSON x :: Parser [()]))
data ServerToClient rep com
= Rep (Reply rep)
| Com (Complete com)
| Pong
deriving (Show, Read, Eq, Generic, Data, Typeable)
instance (Arbitrary sub, Arbitrary sup) => Arbitrary (ServerToClient sub sup) where
arbitrary = do
(q,p) <- arbitrary
if q
then Rep <$> arbitrary
else if p
then Com <$> arbitrary
else pure Pong
instance (ToJSON rep, ToJSON com) => ToJSON (ServerToClient rep com) where
toJSON (Rep x) = toJSON x
toJSON (Com x) = toJSON x
toJSON Pong = toJSON ([] :: [()])
instance (FromJSON rep, FromJSON com) => FromJSON (ServerToClient rep com) where
parseJSON x
= (Rep <$> parseJSON x)
<|> (Com <$> parseJSON x)
<|> (Pong <$ (parseJSON x :: Parser [()]))
data WebSocketRPCException
= WebSocketRPCParseFailure [String] ByteString
deriving (Show, Generic)
instance Exception WebSocketRPCException