Use default config on missing configuration section

On serving initialize request, deserializing HIE configuration embedded in InitializeParam passed by client will result in an error if during process the server cannot find HIE specific configuration key under initializationOptions. This commit changes the initializationOptions deserialization to return the default configuration if configuration key cannot be found under initializationOptions. Here, setting the key with a value of null will also be considered as part of not found condition to accommodate clients that fills missing user options as null.
haskell · Feb 4, 2021 · 4fa8c8f · 4fa8c8f
1 parent 8c7b97b
commit 4fa8c8f
Show file tree

Hide file tree

Showing 2 changed files with 39 additions and 14 deletions.
diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs
@@ -97,20 +97,22 @@ instance A.FromJSON Config where
   parseJSON = A.withObject "Config" $ \v -> do
     -- Officially, we use "haskell" as the section name but for
     -- backwards compatibility we also accept "languageServerHaskell"
-    s <- v .: "haskell" <|> v .: "languageServerHaskell"
-    flip (A.withObject "Config.settings") s $ \o -> Config
-      <$> (o .:? "checkParents" <|> v .:? "checkParents") .!= checkParents def
-      <*> (o .:? "checkProject" <|> v .:? "checkProject") .!= checkProject def
-      <*> o .:? "hlintOn"                                 .!= hlintOn def
-      <*> o .:? "diagnosticsOnChange"                     .!= diagnosticsOnChange def
-      <*> o .:? "maxNumberOfProblems"                     .!= maxNumberOfProblems def
-      <*> o .:? "diagnosticsDebounceDuration"             .!= diagnosticsDebounceDuration def
-      <*> o .:? "liquidOn"                                .!= liquidOn def
-      <*> o .:? "completionSnippetsOn"                    .!= completionSnippetsOn def
-      <*> o .:? "formatOnImportOn"                        .!= formatOnImportOn def
-      <*> o .:? "formattingProvider"                      .!= formattingProvider def
-      <*> o .:? "maxCompletions"                          .!= maxCompletions def
-      <*> o .:? "plugin"                                  .!= plugins def
+    c <- v .: "haskell" <|> v .:? "languageServerHaskell"
+    case c of
+      Nothing -> return def
+      Just s -> flip (A.withObject "Config.settings") s $ \o -> Config
+        <$> (o .:? "checkParents" <|> v .:? "checkParents") .!= checkParents def
+        <*> (o .:? "checkProject" <|> v .:? "checkProject") .!= checkProject def
+        <*> o .:? "hlintOn"                                 .!= hlintOn def
+        <*> o .:? "diagnosticsOnChange"                     .!= diagnosticsOnChange def
+        <*> o .:? "maxNumberOfProblems"                     .!= maxNumberOfProblems def
+        <*> o .:? "diagnosticsDebounceDuration"             .!= diagnosticsDebounceDuration def
+        <*> o .:? "liquidOn"                                .!= liquidOn def
+        <*> o .:? "completionSnippetsOn"                    .!= completionSnippetsOn def
+        <*> o .:? "formatOnImportOn"                        .!= formatOnImportOn def
+        <*> o .:? "formattingProvider"                      .!= formattingProvider def
+        <*> o .:? "maxCompletions"                          .!= maxCompletions def
+        <*> o .:? "plugin"                                  .!= plugins def
 
 -- 2017-10-09 23:22:00.710515298 [ThreadId 11] - ---> {"jsonrpc":"2.0","method":"workspace/didChangeConfiguration","params":{"settings":{"haskell":{"maxNumberOfProblems":100,"hlintOn":true}}}}
 -- 2017-10-09 23:22:00.710667381 [ThreadId 15] - reactor:got didChangeConfiguration notification:

diff --git a/test/functional/Config.hs b/test/functional/Config.hs
@@ -3,6 +3,8 @@
 module Config (tests) where
 
 import           Control.Lens hiding (List)
+import           Control.Applicative.Combinators (skipManyTill)
+import           Control.Monad
 import           Control.Monad.IO.Class
 import           Data.Aeson
 import           Data.Default
@@ -24,6 +26,7 @@ tests = testGroup "plugin config" [
       -- Note: because the flag is treated generically in the plugin handler, we
       -- do not have to test each individual plugin
       hlintTests
+    , configTests
     ]
 
 hlintTests :: TestTree
@@ -71,6 +74,26 @@ hlintTests = testGroup "hlint plugin enables" [
             diags <- waitForDiagnosticsFromSource doc "hlint"
             liftIO $ length diags > 0 @? "There are hlint diagnostics"
 
+configTests :: TestTree
+configTests = testGroup "config parsing" [
+      testCase "empty object as user configuration should not send error logMessage" $ runConfigSession "" $ do
+        let config = object []
+        sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
+
+        -- Send custom request so server returns a response to prevent blocking
+        void $ Test.sendRequest (CustomClientMethod "non-existent-method") ()
+
+        logNot <- skipManyTill Test.anyMessage Test.message :: Session LogMessageNotification
+
+        liftIO $ (logNot ^. L.params . L.xtype) > MtError
+                 || "non-existent-method" `T.isInfixOf` (logNot ^. L.params . L.message)
+                    @? "Server sends logMessage with MessageType = Error"
+    ]
+    where
+        runConfigSession :: FilePath -> Session a -> IO a
+        runConfigSession subdir  =
+            failIfSessionTimeout . runSession hlsCommand fullCaps ("test/testdata" </> subdir)
+
 pluginGlobalOn :: Config -> T.Text -> Bool -> Config
 pluginGlobalOn config pid state = config'
   where