Fix shared-channel Conversation parse; improve Conversation parse err…

…ors (#108)

This bug was found using the conversationsList endpoint, in which our
parse failed on a shared channel.

I have committed an anonymized version of the bad part of the response
as a regression test, and fixed the error messages for Conversations
matching a variant but failing to parse that variant.

Also fixes CI on ghc 9.4 and deletes *.actual files that should be removed anyway.

.github/workflows/haskell-ci.yml

@@ -157,19 +157,6 @@ jobs:
           echo "package slack-web" >> cabal.project
           echo "    ghc-options: -Werror=missing-methods" >> cabal.project
           cat >> cabal.project <<EOF
-          source-repository-package
-            type:     git
-            location: https://github.com/TeofilC/servant.git
-            tag:      a53d69929cf6fe531bb25aec65e7ab6405278459
-            subdir:
-              servant
-              servant-client
-              servant-client-core
-
-          source-repository-package
-            type:     git
-            location: https://github.com/nikita-volkov/refined
-            tag:      eced2bb0991bde971646e4b3d291870d0aab83a3
           EOF
           $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(slack-web)$/; }' >> cabal.project.local
           cat cabal.project

.gitignore

@@ -3,3 +3,4 @@ dist-newstyle/
 cabal.project.local
 # generated by flake.nix
 .pre-commit-config.yaml
+*.actual

cabal.haskell-ci

@@ -1,25 +1,2 @@
 -- Only run the build job on master, since the PR job gets the other branches
 branches: master
-
--- HI! If you add something in here, make sure to copy it to cabal.project if
--- needed!
-raw-project
-  -- for ghc-9.4
-  -- https://github.com/haskell-servant/servant/pull/1592
-  source-repository-package
-    --sha256: sha256-y6fySO8NqtEad+W+F48QJgRR0JYfqXwo/+MCxcrpJpg=
-    type: git
-    location: https://github.com/TeofilC/servant.git
-    tag: a53d69929cf6fe531bb25aec65e7ab6405278459
-    subdir:
-     servant
-     servant-client
-     servant-client-core
-
-  -- https://github.com/nikita-volkov/refined/pull/86
-  -- this was merged, just need to wait for >0.7  to have a release
-  source-repository-package
-    type: git
-    location: https://github.com/nikita-volkov/refined
-    tag: eced2bb0991bde971646e4b3d291870d0aab83a3
-    --sha256: sha256-QvZSFeAmgdBwdyneGRKMCMNGnP+8rD/uTED0icQB+4s=

cabal.project

@@ -2,22 +2,3 @@
 -- add it to raw-project in cabal.haskell-ci
 packages: .
 
--- for ghc-9.4
--- https://github.com/haskell-servant/servant/pull/1592
-source-repository-package
-  --sha256: sha256-y6fySO8NqtEad+W+F48QJgRR0JYfqXwo/+MCxcrpJpg=
-  type: git
-  location: https://github.com/TeofilC/servant.git
-  tag: a53d69929cf6fe531bb25aec65e7ab6405278459
-  subdir:
-   servant
-   servant-client
-   servant-client-core
-
--- https://github.com/nikita-volkov/refined/pull/86
--- this was merged, just need to wait for >0.7  to have a release
-source-repository-package
-  type: git
-  location: https://github.com/nikita-volkov/refined
-  tag: eced2bb0991bde971646e4b3d291870d0aab83a3
-  --sha256: sha256-QvZSFeAmgdBwdyneGRKMCMNGnP+8rD/uTED0icQB+4s=

slack-web.cabal

@@ -20,6 +20,8 @@ description: Haskell bindings for the Slack web API.
 extra-source-files:
   tests/golden/SlackWebhookEvent/*.json
   tests/golden/SlackWebhookEvent/*.golden
+  tests/golden/Conversation/*.json
+  tests/golden/Conversation/*.golden
 
 category: Web
 

src/Web/Slack/Conversation.hs

@@ -37,24 +37,20 @@ module Web.Slack.Conversation
   )
 where
 
--- FIXME: Web.Slack.Prelude
-import Control.Applicative (empty, (<|>))
-import Control.DeepSeq (NFData)
 import Data.Aeson
 import Data.Aeson.Encoding
 import Data.Aeson.KeyMap qualified as KM
 import Data.Aeson.TH
 import Data.Aeson.Types
+import Data.List.NonEmpty (NonEmpty)
 import Data.Scientific
-import Data.Text (Text)
 import Data.Text qualified as T
-import GHC.Generics (Generic)
 import Web.FormUrlEncoded
 import Web.HttpApiData
 import Web.Slack.Common
 import Web.Slack.Pager.Types (PagedRequest (..), PagedResponse (..), ResponseMetadata (..))
+import Web.Slack.Prelude
 import Web.Slack.Util
-import Prelude
 
 data Topic = Topic
   { topicValue :: Text
@@ -96,7 +92,9 @@ data ChannelConversation = ChannelConversation
     channelCreator :: UserId
   , channelIsExtShared :: Bool
   , channelIsOrgShared :: Bool
-  , channelSharedTeamIds :: [TeamId]
+  , channelSharedTeamIds :: Maybe (NonEmpty TeamId)
+  -- ^ Ironically this has been observed to be absent on real shared-channel
+  -- responses.
   , -- FIXME:
     -- I'm not sure the correct type of these fields, because I only found
     -- example responses whose @pending_connected_team_ids@ and
@@ -195,18 +193,29 @@ instance NFData Conversation
 
 instance FromJSON Conversation where
   parseJSON = withObject "Conversation" $ \o ->
-    parseWhen "is_channel" Channel o
-      <|> parseWhen "is_group" Group o
-      <|> parseWhen "is_im" Im o
-      <|> prependFailure
-        "parsing a Conversation failed: neither channel, group, nor im, "
-        (typeMismatch "Conversation" (Object o))
+    fromMaybe (noneMatched o)
+      =<< parseWhen "is_channel" Channel o
+      `parseOr` parseWhen "is_group" Group o
+      `parseOr` parseWhen "is_im" Im o
     where
+      noneMatched o =
+        prependFailure
+          "parsing a Conversation failed: neither channel, group, nor im: "
+          (typeMismatch "Conversation" (Object o))
+
+      -- '(<|>)' that pierces one layer of 'Monad' first
+      parseOr :: (Monad m, Alternative a) => m (a b) -> m (a b) -> m (a b)
+      parseOr = liftM2 (<|>)
+
+      -- This uses the outer Parser monad since deciding which parser to use
+      -- is monadic, then the Maybe to decide which parser is picked, then
+      -- finally the inner parser to actually run it
+      parseWhen :: FromJSON a => Key -> (a -> b) -> Object -> Parser (Maybe (Parser b))
       parseWhen key con o = do
         is <- o .: key
         if is
-          then con <$> parseJSON (Object o)
-          else empty
+          then pure . Just $ con <$> parseJSON (Object o)
+          else pure $ Nothing
 
 instance ToJSON Conversation where
   toJSON (Channel channel) =
@@ -215,8 +224,8 @@ instance ToJSON Conversation where
           . KM.insert "is_channel" (Bool True)
           . KM.insert "is_group" (Bool False)
           $ KM.insert "is_im" (Bool False) obj
-  toJSON (Group group) =
-    let (Object obj) = toJSON group
+  toJSON (Group theGroup) =
+    let (Object obj) = toJSON theGroup
      in Object
           . KM.insert "is_channel" (Bool False)
           . KM.insert "is_group" (Bool True)

tests/Web/Slack/ConversationSpec.hs

@@ -12,6 +12,7 @@ where
 import Data.Aeson
 -- time
 import Data.Time.Clock.POSIX
+import JSONGolden
 import Test.Hspec.QuickCheck
 import Test.QuickCheck
 import Test.QuickCheck.Instances ()
@@ -111,3 +112,26 @@ spec = describe "ToJSON and FromJSON for Conversation" $ do
   prop "the encoded json is decoded as " $ \conversation -> do
     actual <- either fail return . eitherDecode $ encode conversation
     actual `shouldBe` (conversation :: Conversation)
+
+  describe "Golden tests" $ do
+    mapM_ (oneGoldenTest @Conversation) ["shared_channel"]
+
+  it "errors accurately if no variant matches" $ do
+    let badData =
+          object
+            [ ("is_group", Bool False)
+            , ("is_im", Bool False)
+            , ("is_channel", Bool False)
+            ]
+    fromJSON @Conversation badData
+      `shouldBe` Error "parsing a Conversation failed: neither channel, group, nor im: expected Conversation, but encountered Object"
+
+  it "has good errors if a variant matches but is missing fields" $ do
+    let badData =
+          object
+            [ ("is_group", Bool False)
+            , ("is_im", Bool False)
+            , ("is_channel", Bool True)
+            ]
+    fromJSON @Conversation badData
+      `shouldBe` Error "When parsing the record ChannelConversation of type Web.Slack.Conversation.ChannelConversation the key id was not present."

tests/golden/Conversation/shared_channel.golden

@@ -0,0 +1,32 @@
+Channel
+    ( ChannelConversation
+        { channelId = ConversationId
+            { unConversationId = "C0000000000" }
+        , channelName = "shared-channel"
+        , channelCreated = 1667519517
+        , channelIsArchived = False
+        , channelIsGeneral = False
+        , channelUnlinked = 0
+        , channelNameNormalized = "shared-channel"
+        , channelIsShared = True
+        , channelCreator = UserId
+            { unUserId = "UAAAAAAAA" }
+        , channelIsExtShared = True
+        , channelIsOrgShared = False
+        , channelSharedTeamIds = Nothing
+        , channelIsPendingExtShared = False
+        , channelIsMember = Just False
+        , channelTopic = Topic
+            { topicValue = ""
+            , topicCreator = ""
+            , topicLastSet = 0
+            }
+        , channelPurpose = Purpose
+            { purposeValue = ""
+            , purposeCreator = ""
+            , purposeLastSet = 0
+            }
+        , channelPreviousNames = []
+        , channelNumMembers = Just 12
+        }
+    )

tests/golden/Conversation/shared_channel.json

@@ -0,0 +1,37 @@
+{
+  "id": "C0000000000",
+  "name": "shared-channel",
+  "is_channel": true,
+  "is_group": false,
+  "is_im": false,
+  "is_mpim": false,
+  "is_private": false,
+  "created": 1667519517,
+  "is_archived": false,
+  "is_general": false,
+  "unlinked": 0,
+  "name_normalized": "shared-channel",
+  "is_shared": true,
+  "is_org_shared": false,
+  "is_pending_ext_shared": false,
+  "pending_shared": [],
+  "context_team_id": "TAAAAAAAA",
+  "parent_conversation": null,
+  "creator": "UAAAAAAAA",
+  "is_ext_shared": true,
+  "pending_connected_team_ids": [],
+  "conversation_host_id": "TAAAAAAAA",
+  "is_member": false,
+  "topic": {
+    "value": "",
+    "creator": "",
+    "last_set": 0
+  },
+  "purpose": {
+    "value": "",
+    "creator": "",
+    "last_set": 0
+  },
+  "previous_names": [],
+  "num_members": 12
+}