encode and decode Event and Payload correctly

Author: banacorn

Web/SocketIO/Types/Event.hs

@@ -20,8 +20,10 @@ import              Web.SocketIO.Types.String
 import              Control.Applicative
 import              Data.Aeson                              
 import              Data.Aeson.Encode               (encodeToTextBuilder)
+import              Data.List                       (intersperse)                              
 import              Data.Text.Internal.Builder      (toLazyText)
-import              Data.Vector                     (toList)                         
+import qualified    Data.Text.Lazy                  as TL
+import              Data.Vector                     (toList)
 --------------------------------------------------------------------------------
 -- | Name of an Event
 type EventName = Text
@@ -30,14 +32,19 @@ type EventName = Text
 -- | Payload carried by an Event
 data Payload = Payload [Text] deriving (Eq, Show)
 
+instance Serializable Payload where
+    serialize (Payload payload) = serialize $ '[' `TL.cons` (TL.concat $ intersperse "," payload) `TL.snoc` ']'
+
 --------------------------------------------------------------------------------
 -- | Event
 data Event = Event EventName Payload
            | NoEvent                    -- ^ some malformed shit
            deriving (Show, Eq)
 
 instance Serializable Event where
-   serialize = serialize . encode
+   serialize (Event name (Payload [])) = serialize $ "{\"name\":\"" `TL.append` name `TL.append` "\"}"
+   serialize (Event name payload) = serialize $ "{\"name\":\"" `TL.append` name `TL.append` "\",\"args\":" `TL.append` serialize payload `TL.append` "}"
+   serialize NoEvent = ""
 
 instance FromJSON Event where
    parseJSON (Object v) = Event <$>
@@ -51,8 +58,8 @@ instance FromJSON Event where
    parseJSON _ = return NoEvent
 
 instance ToJSON Event where
-  toJSON (Event name (Payload []))   = object ["name" .= name]
-  toJSON (Event name (Payload args)) = object ["name" .= name, "args" .= args]
+  toJSON (Event name (Payload []))      = object ["name" .= name]
+  toJSON (Event name (Payload payload)) = object ["name" .= name, "args" .= payload]
   toJSON NoEvent = object []
 
 --------------------------------------------------------------------------------

test/Test/Instances/Value.hs

@@ -4,7 +4,7 @@
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
-module Test.Instances.Value (Value(..)) where
+module Test.Instances.Value (Value(..), arbitraryJSONString) where
 
 import              Web.SocketIO.Types.String              
 
@@ -14,6 +14,7 @@ import              Data.Aeson.Types
 import              Data.Aeson.Encode                       (encode)
 import qualified    Data.HashMap.Strict                     as H
 import              Data.Scientific                         (Scientific, scientific)
+import qualified    Data.Text.Lazy                          as TL
 import              Data.Vector                             (fromList)
 import              Test.QuickCheck
 
@@ -28,6 +29,9 @@ instance Serializable Value where
 instance Arbitrary StrictText where
     arbitrary = fmap fromString arbitrary
 
+instance Arbitrary Text where
+    arbitrary = fmap fromString arbitrary
+
 instance Arbitrary Scientific where
     arbitrary = do
         c <- arbitrary
@@ -41,9 +45,15 @@ instance Arbitrary Value where
         s <- arbitrary
         n <- arbitrary
         b <- arbitrary
-        elements [Object o, Array a, String s, Number n, Bool b, Null]
+        elements [Object o, Array a, String s, Number n, Bool b]
 
         where   arbitraryPair = do
                     k <- arbitrary
                     v <- arbitrary
-                    return (k, v)
+                    return (k, v)
+
+arbitraryJSONString :: Gen Text
+arbitraryJSONString = TL.filter badthings <$> arbitrary
+    where   badthings '"' = False
+            badthings '\\' = False
+            badthings _ = True

test/Test/Protocol.hs

@@ -10,6 +10,7 @@ module Test.Protocol (test) where
 import              Web.SocketIO.Types
 import              Web.SocketIO.Protocol
 
+import Data.Aeson
 import              Test.Instances.Value
 --------------------------------------------------------------------------------
 import              Control.Applicative                     ((<$>))
@@ -37,14 +38,16 @@ instance Arbitrary Data where
         d <- friendlyStringGen
         elements [NoData, Data d]
 
-instance Arbitrary Text where
-    arbitrary = fmap fromString arbitrary
+instance Arbitrary Payload where
+    arbitrary = do
+        payload <- map serialize <$> listOf (arbitrary :: Gen Value)
+        return $ Payload payload
 
 instance Arbitrary Event where
     arbitrary = do
-        eventName <- arbitrary
-        --payload <- arbitrary
-        elements [NoEvent, Event eventName (Payload [])]
+        eventName <- arbitraryJSONString
+        payload <- arbitrary
+        elements [NoEvent, Event eventName payload]
 
 instance Arbitrary Message where
     arbitrary = do