Merge pull request #509 from haskell/mpj/fix-notification-messages

Fix parsing of notifications with missing params

lsp-types/src/Language/LSP/Protocol/Message/Types.hs

@@ -108,8 +108,19 @@ data TNotificationMessage (m :: Method f Notification) =
 deriving stock instance Eq   (MessageParams m) => Eq (TNotificationMessage m)
 deriving stock instance Show (MessageParams m) => Show (TNotificationMessage m)
 
+{- Note [Missing 'params']
+The 'params' field on requrests and notificaoins may be omitted according to the
+JSON-RPC spec, but that doesn't quite work the way we want with the generic aeson
+instance. Even if the 'MessageParams' type family happens to resolve to a 'Maybe',
+we handle it generically and so we end up asserting that it must be present.
+
+We fix this in a slightly dumb way by just adding the field in if it is missing,
+set to null (which parses correctly for those 'Maybe' parameters also).
+-}
+
 instance (FromJSON (MessageParams m), FromJSON (SMethod m)) => FromJSON (TNotificationMessage m) where
-  parseJSON = genericParseJSON lspOptions
+  -- See Note [Missing 'params']
+  parseJSON = genericParseJSON lspOptions . addNullField "params"
 instance (ToJSON (MessageParams m)) => ToJSON (TNotificationMessage m) where
   toJSON     = genericToJSON lspOptions
   toEncoding = genericToEncoding lspOptions
@@ -126,6 +137,7 @@ deriving stock instance Eq   (MessageParams m) => Eq (TRequestMessage m)
 deriving stock instance Show (MessageParams m) => Show (TRequestMessage m)
 
 instance (FromJSON (MessageParams m), FromJSON (SMethod m)) => FromJSON (TRequestMessage m) where
+  -- See Note [Missing 'params']
   parseJSON = genericParseJSON lspOptions . addNullField "params"
 instance (ToJSON (MessageParams m)) => ToJSON (TRequestMessage m) where
   toJSON     = genericToJSON lspOptions

lsp-types/test/JsonSpec.hs

@@ -41,7 +41,9 @@ main = hspec spec
 spec :: Spec
 spec = do
   describe "dispatcher" jsonSpec
-  describe "ResponseMessage"  responseMessageSpec
+  describe "RequestMessage" requestMessageSpec
+  describe "ResponseMessage" responseMessageSpec
+  describe "NotificationMesssage" notificationMessageSpec
 
 -- ---------------------------------------------------------------------
 
@@ -61,16 +63,20 @@ jsonSpec = do
         `shouldNotBe` Nothing
 
 
+requestMessageSpec :: Spec
+requestMessageSpec = do
+  describe "edge cases" $ do
+    it "handles missing params field" $ do
+      J.eitherDecode "{ \"jsonrpc\": \"2.0\", \"id\": 15, \"method\": \"shutdown\"}"
+        `shouldBe` Right (TRequestMessage "2.0" (IdInt 15) SMethod_Shutdown Nothing)
+
 responseMessageSpec :: Spec
 responseMessageSpec = do
   describe "edge cases" $ do
     it "decodes result = null" $ do
       let input = "{\"jsonrpc\": \"2.0\", \"id\": 123, \"result\": null}"
         in  J.decode input `shouldBe` Just
               ((TResponseMessage "2.0" (Just (IdInt 123)) (Right $ InL J.Null)) :: TResponseMessage 'Method_WorkspaceExecuteCommand)
-    it "handles missing params field" $ do
-      J.eitherDecode "{ \"jsonrpc\": \"2.0\", \"id\": 15, \"method\": \"shutdown\"}"
-        `shouldBe` Right (TRequestMessage "2.0" (IdInt 15) SMethod_Shutdown Nothing)
   describe "invalid JSON" $ do
     it "throws if neither result nor error is present" $ do
       (J.eitherDecode "{\"jsonrpc\":\"2.0\",\"id\":1}" :: Either String (TResponseMessage 'Method_Initialize))
@@ -82,6 +88,13 @@ responseMessageSpec = do
         `shouldSatisfy`
           (either (\err -> "Error in $: both error and result cannot be present" `isPrefixOf` err) (\_ -> False))
 
+notificationMessageSpec :: Spec
+notificationMessageSpec = do
+  describe "edge cases" $ do
+    it "handles missing params field" $ do
+      J.eitherDecode "{ \"jsonrpc\": \"2.0\", \"method\": \"exit\"}"
+        `shouldBe` Right (TNotificationMessage "2.0" SMethod_Exit Nothing)
+
 -- ---------------------------------------------------------------------
 
 propertyJsonRoundtrip :: (Eq a, Show a, J.ToJSON a, J.FromJSON a) => a -> Property