Haskell JSON Web API Generalization

Question

I am trying to write a Twitch chat bot that will receive messages. The messages will be in JSON and be an object of two other objects, metadata (which appears to be mostly standardized across all message types) and payload (which is vastly different from message type to message type).

What I am trying to achieve is one Message type with a Metadata type and an Existential Quantification of Payload types. The part that is tripping me up is getting it to parse the Payload types in a non-boilerplate fashion. I have a generic fromJSON function within a class (intentionally named different than parseJSON) with a default implementation that should work for all of the Payload types, but the compiler is getting hung up on the Existential Quantification type, because it is not an instance of the MessagePayload class, even though all Payload types (e.g. AccessToken and Session) are.

Is there a way to resolve the Payload's type generically within Message's parseJSON function without writing a case statement that I would have to constantly update as I make more of these Payload types throughout the course of this project?

Here is the code in question that I've got up to this point:

{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE OverloadedStrings          #-}

module Twitch.Types ( AccessToken (..)
                    , Session (..)
                    , Message (..)
                    , MessagePayload (..)
                    , MessagePayloadType (..)
                    ) where

import Data.Aeson hiding (fromJSON, Key)
import qualified Data.Aeson.Key as K
import Data.Aeson.Casing
import Data.Aeson.Types (Parser)
import Data.Text
import qualified Data.Text as T
import Data.Time
import GHC.Generics

import Internal.Types
import DB (storeToken)
import DB.Internal (runDB)
import DB.Model


data Message = Message { metadata :: Metadata
                       , payload  :: MessagePayloadType
                       }
                       deriving (Generic)

instance FromJSON Message where
    parseJSON = withObject "" $ \v -> do
        metadata     <- v .: "metadata"
        payloadValue <- v .: "payload"
        payload      <- MessagePayloadType <$> fromJSON metadata payloadValue  
        return $ Message metadata payload


data Metadata = Metadata { messageID :: String
                         , messageType :: String
                         , messageTimestamp :: UTCTime
                         }
                         deriving (Generic, Show)

instance FromJSON Metadata where
    parseJSON = genericParseJSON $ aesonPrefix snakeCase


-- TODO: Need to eventually expand so it can return any Key, but Token
--       is the only db table we have for now.
class MessagePayload a where
    dbInsert :: App -> a -> IO (Key Token)
    fromJSON :: Metadata -> Value -> Parser a
    fromJSON m v = withObject "payload"
                              (\p -> do
                                        obj <- p .: ( K.fromString
                                                    $ msgTypeToJSONObjectName
                                                    $ messageType m
                                                    )
                                        genericParseJSON (aesonPrefix snakeCase) obj
                              )
                              v

data MessagePayloadType = forall mp . MessagePayload mp => MessagePayloadType mp


msgTypeToJSONObjectName :: String -> String
msgTypeToJSONObjectName s =
        case s of
            "session_welcome" -> "session"
            _ -> error $ "Twitch Message Type " ++
                         s ++
                         " not found. Update Twitch.Types.messageTypeToJSONObjectName."


data Session = Session { sessionId :: Text
                       , status :: Text
                       , connectedAt :: UTCTime
                       , keepaliveTimeoutSeconds :: Int
                       , reconnectUrl :: Maybe Text
                       }
                       deriving (Generic, Show)

instance TokenData Session where
    getToken = sessionId
    getExpiresIn = keepaliveTimeoutSeconds
    getTokenType _ = Nothing

instance MessagePayload Session where
    dbInsert app s = runDB (storeToken Twitch Access s) app


data AccessToken = AT { atAccessToken :: Text
                      , atExpiresIn :: Int
                      , atTokenType :: Text
                      }
                   deriving (Generic, Show)

instance TokenData AccessToken where
    getToken = atAccessToken
    getExpiresIn = atExpiresIn
    getTokenType = Just . atTokenType

instance MessagePayload AccessToken where
    dbInsert app at = runDB (storeToken Twitch Access at) app

Daniel Wagner · Accepted Answer · 2025-09-12 00:20:18Z

3

Because the type determines what parser to use, you must have some way of determining the type before you parse the payload; for example:

data PayloadType = TypeSession | TypeToken

payloadType :: Metadata -> PayloadType
payloadType = undefined

instance FromJSON Message where
    parseJSON = withObject "" \v -> do
        metadata <- v .: "metadata"
        payload <- case payloadType metadata of
            TypeSession -> MessagePayloadType <$> (v .: "payload" :: Parser Session)
            TypeToken -> MessagePayloadType <$> (v .: "payload" :: Parser Token)
        return $ Message metadata payload

You may try several types and take the first success; for example:

data TypedPayload = PayloadSession Session | PayloadToken AccessToken

forgetType :: TypedPayload -> MessagePayloadType
forgetType = \case
    PayloadSession s -> MessagePayloadType s
    PayloadToken t -> MessagePayloadType t

instance FromJSON Message where
    parseJSON = withObject "" \v -> do
        metadata <- v .: "metadata"
        payload <- (PayloadSession <$> (v .: "payload"))
               <|> (PayloadToken <$> (v .: "payload"))
        return $ Message metadata (forgetType payload)

Beware that a payload which could successfully parse as either type will be biased towards one or the other, depending on the order of arguments to <|>. Of course you may use the usual programming tools/abstraction layers to reduce the repetition somewhat with either approach.

Those are your two options. I'm sure you won't like that answer; nevertheless it is the answer.

answered Sep 12 at 0:20

Daniel Wagner

156k10 gold badges231 silver badges392 bronze badges

Sign up to request clarification or add additional context in comments.

2 Comments

Jason Harrer Sep 18 at 12:23

Thank you so much for the response, and my apologies that it took so long to get a chance to really review it. You're right that I don't like the response, not because it's wrong, but because existential quantification doesn't appear to work the way I thought it should. Based on your response, I'm understanding you to say that a GADT of all the payload types will be required regardless, so it may be best to just remove the existential quantification. Is that accurate? If not, can you explain how existential quantification may still be beneficial? I really want to understand this. Than

Daniel Wagner Sep 18 at 14:27

Yep, that sounds right to me!

Collectives™ on Stack Overflow

Haskell JSON Web API Generalization

1 Answer 1

2 Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

2 Comments

Your Answer

Sign up or log in

Post as a guest

Related