http2-5.0.0: test-frame/JSON.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module JSON where

#if __GLASGOW_HASKELL__ < 709
import Control.Applicative ((<$>), (<*>))
#endif
import Control.Arrow (first)
import Control.Monad (mzero)
import Data.Aeson
import Data.Aeson.KeyMap (union)
import Data.Aeson.Types
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8
import Data.Maybe (fromJust)
import Data.Text (Text)
import qualified Data.Text as T

import Network.HTTP2.Frame

----------------------------------------------------------------

byteStringToText :: ByteString -> Text
byteStringToText = T.pack . B8.unpack

textToByteString :: Text -> ByteString
textToByteString = B8.pack . T.unpack

(+++) :: Value -> Value -> Value
Object x +++ Object y = Object $ x `union` y
Null +++ x = x
x +++ Null = x
_ +++ _ = error "+++"

----------------------------------------------------------------

data FramePad = FramePad
    { fpFrame :: Frame
    , fpPad :: Maybe Pad
    }
    deriving (Show, Read)

newtype Pad = Pad Padding deriving (Show, Read)

unPad :: Pad -> Padding
unPad (Pad x) = x

----------------------------------------------------------------

data Case = Case
    { description :: String
    , wire :: ByteString
    , frame :: Maybe FramePad
    , err :: Maybe [ErrorCode]
    }
    deriving (Show, Read)

----------------------------------------------------------------

{-
instance ToJSON StreamIdentifier where
    toJSON (StreamIdentifier s) = toJSON s

instance FromJSON StreamIdentifier where
    parseJSON x = StreamIdentifier <$> parseJSON x
-}

instance ToJSON ErrorCode where
    toJSON e = toJSON $ fromErrorCode e

instance FromJSON ErrorCode where
    parseJSON e = toErrorCode <$> parseJSON e

instance ToJSON FrameType where
    toJSON e = toJSON $ fromFrameType e

instance FromJSON FrameType where
    parseJSON e = toFrameType <$> parseJSON e

instance {-# OVERLAPPING #-} ToJSON SettingsList where
    toJSON settings = toJSON $ map (first fromSettingsKey) settings

instance {-# OVERLAPPING #-} FromJSON SettingsList where
    parseJSON x = map (first toSettingsKey) <$> parseJSON x

instance ToJSON ByteString where
    toJSON bs = toJSON $ byteStringToText bs

instance FromJSON ByteString where
    parseJSON x = textToByteString <$> parseJSON x

----------------------------------------------------------------

instance ToJSON FramePayload where
    toJSON (DataFrame body) =
        object
            [ "data" .= body
            ]
    toJSON (HeadersFrame mpri hdr) =
        object
            [ "exclusive" .= maybe Null (toJSON . exclusive) mpri
            , "stream_dependency" .= maybe Null (toJSON . streamDependency) mpri
            , "weight" .= maybe Null (toJSON . weight) mpri
            , "header_block_fragment" .= hdr
            ]
    toJSON (PriorityFrame pri) =
        object
            [ "exclusive" .= exclusive pri
            , "stream_dependency" .= streamDependency pri
            , "weight" .= weight pri
            ]
    toJSON (RSTStreamFrame e) =
        object
            [ "error_code" .= e
            ]
    toJSON (SettingsFrame settings) =
        object
            [ "settings" .= settings
            ]
    toJSON (PushPromiseFrame sid hdr) =
        object
            [ "promised_stream_id" .= sid
            , "header_block_fragment" .= hdr
            ]
    toJSON (PingFrame odata) =
        object
            [ "opaque_data" .= odata
            ]
    toJSON (GoAwayFrame sid e debug) =
        object
            [ "last_stream_id" .= sid
            , "error_code" .= e
            , "additional_debug_data" .= debug
            ]
    toJSON (WindowUpdateFrame size) =
        object
            [ "window_size_increment" .= size
            ]
    toJSON (ContinuationFrame hdr) =
        object
            [ "header_block_fragment" .= hdr
            ]
    toJSON (UnknownFrame _ opaque) =
        object
            [ "payload" .= opaque
            ]

----------------------------------------------------------------

instance ToJSON FramePad where
    toJSON FramePad{fpFrame = Frame{..}, ..} =
        object
            [ "length" .= payloadLength frameHeader
            , "type" .= framePayloadToFrameType framePayload
            , "flags" .= flags frameHeader
            , "stream_identifier" .= streamId frameHeader
            , "frame_payload" .= (toJSON framePayload +++ padObj)
            ]
      where
        padObj = case toJSON fpPad of
            Null
                | isPaddingDefined framePayload -> emptyPad
                | otherwise -> noPad
            x -> x

instance FromJSON FramePad where
    parseJSON (Object o) = do
        len <- o .: "length"
        typ <- o .: "type"
        flg <- o .: "flags"
        sid <- o .: "stream_identifier"
        pld <- o .: "frame_payload"
        (payload, mpad) <- parsePayloadPad typ pld
        return
            FramePad
                { fpFrame =
                    Frame
                        { frameHeader = FrameHeader len flg sid
                        , framePayload = payload
                        }
                , fpPad = mpad
                }
    parseJSON _ = mzero

parsePayloadPad :: FrameType -> Object -> Parser (FramePayload, Maybe Pad)
parsePayloadPad ftyp o = do
    mpad <- (Pad <$>) <$> o .:? "padding"
    payload <- parsePayload ftyp o
    return (payload, mpad)

priority :: Object -> Parser Priority
priority o =
    Priority
        <$> o .: "exclusive"
        <*> o .: "stream_dependency"
        <*> o .: "weight"

mpriority :: Object -> Parser (Maybe Priority)
mpriority o = do
    me <- o .:? "exclusive"
    ms <- o .:? "stream_dependency"
    mw <- o .:? "weight"
    return $ case me of
        Nothing -> Nothing
        Just ex -> Just $ Priority ex (fromJust ms) (fromJust mw)

parsePayload :: FrameType -> Object -> Parser FramePayload
parsePayload FrameData o = DataFrame <$> o .: "data"
parsePayload FrameHeaders o = do
    mpri <- mpriority o
    hdr <- o .: "header_block_fragment"
    return $ HeadersFrame mpri hdr
parsePayload FramePriority o = PriorityFrame <$> priority o
parsePayload FrameRSTStream o = RSTStreamFrame <$> o .: "error_code"
parsePayload FrameSettings o = SettingsFrame <$> o .: "settings"
parsePayload FramePushPromise o =
    PushPromiseFrame
        <$> o .: "promised_stream_id"
        <*> o .: "header_block_fragment"
parsePayload FramePing o = PingFrame <$> o .: "opaque_data"
parsePayload FrameGoAway o =
    GoAwayFrame
        <$> o .: "last_stream_id"
        <*> o .: "error_code"
        <*> o .: "additional_debug_data"
parsePayload FrameWindowUpdate o = WindowUpdateFrame <$> o .: "window_size_increment"
parsePayload FrameContinuation o = ContinuationFrame <$> o .: "header_block_fragment"
parsePayload ftyp o = UnknownFrame ftyp <$> o .: "dummy"

instance ToJSON Pad where
    toJSON (Pad padding) =
        object
            [ "padding_length" .= BS.length padding
            , "padding" .= padding
            ]

emptyPad :: Value
emptyPad =
    object
        [ "padding_length" .= Null
        , "padding" .= Null
        ]

noPad :: Value
noPad = object []

----------------------------------------------------------------

instance ToJSON Case where
    toJSON Case{..} =
        object
            [ "description" .= description
            , "wire" .= wire
            , "frame" .= frame
            , "error" .= err
            ]

instance FromJSON Case where
    parseJSON (Object o) =
        Case
            <$> o .: "description"
            <*> o .: "wire"
            <*> o .:? "frame"
            <*> o .:? "error"
    parseJSON _ = mzero