ceph/src/jaegertracing/thrift/lib/hs/src/Thrift/Protocol/JSON.hs

   1 --
   2 -- Licensed to the Apache Software Foundation (ASF) under one
   3 -- or more contributor license agreements. See the NOTICE file
   4 -- distributed with this work for additional information
   5 -- regarding copyright ownership. The ASF licenses this file
   6 -- to you under the Apache License, Version 2.0 (the
   7 -- "License"); you may not use this file except in compliance
   8 -- with the License. You may obtain a copy of the License at
   9 --
  10 --   http://www.apache.org/licenses/LICENSE-2.0
  11 --
  12 -- Unless required by applicable law or agreed to in writing,
  13 -- software distributed under the License is distributed on an
  14 -- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
  15 -- KIND, either express or implied. See the License for the
  16 -- specific language governing permissions and limitations
  17 -- under the License.
  18 --
  19
  20 {-# LANGUAGE CPP #-}
  21 {-# LANGUAGE ExistentialQuantification #-}
  22 {-# LANGUAGE OverloadedStrings #-}
  23 {-# LANGUAGE ScopedTypeVariables #-}
  24 {-# LANGUAGE TupleSections #-}
  25
  26 module Thrift.Protocol.JSON
  27     ( module Thrift.Protocol
  28     , JSONProtocol(..)
  29     ) where
  30
  31 import Control.Applicative
  32 import Control.Exception (bracket)
  33 import Control.Monad
  34 import Data.Attoparsec.ByteString as P
  35 import Data.Attoparsec.ByteString.Char8 as PC
  36 import Data.Attoparsec.ByteString.Lazy as LP
  37 import Data.ByteString.Base64.Lazy as B64C
  38 import Data.ByteString.Lazy.Builder as B
  39 import Data.ByteString.Internal (c2w, w2c)
  40 import Data.Functor
  41 import Data.Int
  42 import Data.List
  43 import Data.Maybe (catMaybes)
  44 import Data.Monoid
  45 import Data.Text.Lazy.Encoding
  46 import Data.Word
  47 import qualified Data.HashMap.Strict as Map
  48
  49 import Thrift.Protocol
  50 import Thrift.Transport
  51 import Thrift.Types
  52
  53 import qualified Data.ByteString.Lazy as LBS
  54 import qualified Data.ByteString.Lazy.Char8 as LBSC
  55 import qualified Data.Text.Lazy as LT
  56
  57 -- | The JSON Protocol data uses the standard 'TJSONProtocol'.  Data is
  58 -- encoded as a JSON 'ByteString'
  59 data JSONProtocol t = JSONProtocol t
  60                       -- ^ Construct a 'JSONProtocol' with a 'Transport'
  61 getTransport :: Transport t => JSONProtocol t -> t
  62 getTransport (JSONProtocol t) = t
  63
  64 instance Transport t => Protocol (JSONProtocol t) where
  65     readByte p = tReadAll (getTransport p) 1
  66
  67     writeMessage (JSONProtocol t) (s, ty, sq) = bracket readMessageBegin readMessageEnd . const
  68       where
  69         readMessageBegin = tWrite t $ toLazyByteString $
  70           B.char8 '[' <> buildShowable (1 :: Int32) <>
  71           B.string8 ",\"" <> escape (encodeUtf8 s) <> B.char8 '\"' <>
  72           B.char8 ',' <> buildShowable (fromEnum ty) <>
  73           B.char8 ',' <> buildShowable sq <>
  74           B.char8 ','
  75         readMessageEnd _ = do
  76           tWrite t "]"
  77           tFlush t
  78
  79     readMessage p = bracket readMessageBegin readMessageEnd
  80       where
  81         readMessageBegin = runParser p $ skipSpace *> do
  82           _ver :: Int32 <- lexeme (PC.char8 '[') *> lexeme (signed decimal)
  83           bs <- lexeme (PC.char8 ',') *> lexeme escapedString
  84           case decodeUtf8' bs of
  85             Left _ -> fail "readMessage: invalid text encoding"
  86             Right str -> do
  87               ty <- toEnum <$> (lexeme (PC.char8 ',') *> lexeme (signed decimal))
  88               seqNum <- lexeme (PC.char8 ',') *> lexeme (signed decimal)
  89               _ <- PC.char8 ','
  90               return (str, ty, seqNum)
  91         readMessageEnd _ = void $ runParser p (PC.char8 ']')
  92
  93     writeVal p = tWrite (getTransport p) . toLazyByteString . buildJSONValue
  94     readVal p ty = runParser p $ skipSpace *> parseJSONValue ty
  95
  96 instance Transport t => StatelessProtocol (JSONProtocol t) where
  97     serializeVal _ = toLazyByteString . buildJSONValue
  98     deserializeVal _ ty bs =
  99       case LP.eitherResult $ LP.parse (parseJSONValue ty) bs of
 100         Left s -> error s
 101         Right val -> val
 102
 103 -- Writing Functions
 104
 105 buildJSONValue :: ThriftVal -> Builder
 106 buildJSONValue (TStruct fields) = B.char8 '{' <> buildJSONStruct fields <> B.char8 '}'
 107 buildJSONValue (TMap kt vt entries) =
 108   B.char8 '[' <> B.char8 '"' <> getTypeName kt <> B.char8 '"' <>
 109   B.char8 ',' <> B.char8 '"' <> getTypeName vt <> B.char8 '"' <>
 110   B.char8 ',' <> buildShowable (length entries) <>
 111   B.char8 ',' <> B.char8 '{' <> buildJSONMap entries <> B.char8 '}' <>
 112   B.char8 ']'
 113 buildJSONValue (TList ty entries) =
 114   B.char8 '[' <> B.char8 '"' <> getTypeName ty <> B.char8 '"' <>
 115   B.char8 ',' <> buildShowable (length entries) <>
 116   (if length entries > 0
 117    then B.char8 ',' <> buildJSONList entries
 118    else mempty) <>
 119   B.char8 ']'
 120 buildJSONValue (TSet ty entries) = buildJSONValue (TList ty entries)
 121 buildJSONValue (TBool b) = if b then B.char8 '1' else B.char8 '0'
 122 buildJSONValue (TByte b) = buildShowable b
 123 buildJSONValue (TI16 i) = buildShowable i
 124 buildJSONValue (TI32 i) = buildShowable i
 125 buildJSONValue (TI64 i) = buildShowable i
 126 buildJSONValue (TDouble d) = buildShowable d
 127 buildJSONValue (TString s) = B.char8 '\"' <> escape s <> B.char8 '\"'
 128 buildJSONValue (TBinary s) = B.char8 '\"' <> (B.lazyByteString . B64C.encode $ s) <> B.char8 '\"'
 129
 130 buildJSONStruct :: Map.HashMap Int16 (LT.Text, ThriftVal) -> Builder
 131 buildJSONStruct = mconcat . intersperse (B.char8 ',') . Map.foldrWithKey buildField []
 132   where
 133     buildField fid (_,val) = (:) $
 134       B.char8 '"' <> buildShowable fid <> B.string8 "\":" <>
 135       B.char8 '{' <>
 136       B.char8 '"' <> getTypeName (getTypeOf val) <> B.string8 "\":" <>
 137       buildJSONValue val <>
 138       B.char8 '}'
 139
 140 buildJSONMap :: [(ThriftVal, ThriftVal)] -> Builder
 141 buildJSONMap = mconcat . intersperse (B.char8 ',') . map buildKV
 142   where
 143     buildKV (key@(TString _), val) =
 144       buildJSONValue key <> B.char8 ':' <> buildJSONValue val
 145     buildKV (key, val) =
 146       B.char8 '\"' <> buildJSONValue key <> B.string8 "\":" <> buildJSONValue val
 147 buildJSONList :: [ThriftVal] -> Builder
 148 buildJSONList = mconcat . intersperse (B.char8 ',') . map buildJSONValue
 149
 150 buildShowable :: Show a => a ->  Builder
 151 buildShowable = B.string8 . show
 152
 153 -- Reading Functions
 154
 155 parseJSONValue :: ThriftType -> Parser ThriftVal
 156 parseJSONValue (T_STRUCT tmap) =
 157   TStruct <$> (lexeme (PC.char8 '{') *> parseJSONStruct tmap <* PC.char8 '}')
 158 parseJSONValue (T_MAP kt vt) = fmap (TMap kt vt) $
 159   between '[' ']' $
 160     lexeme escapedString *> lexeme (PC.char8 ',') *>
 161     lexeme escapedString *> lexeme (PC.char8 ',') *>
 162     lexeme decimal *> lexeme (PC.char8 ',') *>
 163     between '{' '}' (parseJSONMap kt vt)
 164 parseJSONValue (T_LIST ty) = fmap (TList ty) $
 165   between '[' ']' $ do
 166     len <- lexeme escapedString *> lexeme (PC.char8 ',') *> lexeme decimal
 167     if len > 0
 168       then lexeme (PC.char8 ',') *> parseJSONList ty
 169       else return []
 170 parseJSONValue (T_SET ty) = fmap (TSet ty) $
 171   between '[' ']' $ do
 172     len <- lexeme escapedString *> lexeme (PC.char8 ',') *> lexeme decimal
 173     if len > 0
 174       then  lexeme (PC.char8 ',') *> parseJSONList ty
 175       else return []
 176 parseJSONValue T_BOOL =
 177   (TBool True <$ PC.char8 '1') <|> (TBool False <$ PC.char8 '0')
 178 parseJSONValue T_BYTE = TByte <$> signed decimal
 179 parseJSONValue T_I16 = TI16 <$> signed decimal
 180 parseJSONValue T_I32 = TI32 <$> signed decimal
 181 parseJSONValue T_I64 = TI64 <$> signed decimal
 182 parseJSONValue T_DOUBLE = TDouble <$> double
 183 parseJSONValue T_STRING = TString <$> escapedString
 184 parseJSONValue T_BINARY = TBinary <$> base64String
 185 parseJSONValue T_STOP = fail "parseJSONValue: cannot parse type T_STOP"
 186 parseJSONValue T_VOID = fail "parseJSONValue: cannot parse type T_VOID"
 187
 188 parseAnyValue :: Parser ()
 189 parseAnyValue = choice $
 190                 skipBetween '{' '}' :
 191                 skipBetween '[' ']' :
 192                 map (void . parseJSONValue)
 193                   [ T_BOOL
 194                   , T_I16
 195                   , T_I32
 196                   , T_I64
 197                   , T_DOUBLE
 198                   , T_STRING
 199                   , T_BINARY
 200                   ]
 201   where
 202     skipBetween :: Char -> Char -> Parser ()
 203     skipBetween a b = between a b $ void (PC.satisfy (\c -> c /= a && c /= b))
 204                                           <|> skipBetween a b
 205
 206 parseJSONStruct :: TypeMap -> Parser (Map.HashMap Int16 (LT.Text, ThriftVal))
 207 parseJSONStruct tmap = Map.fromList . catMaybes <$> parseField
 208                        `sepBy` lexeme (PC.char8 ',')
 209   where
 210     parseField = do
 211       fid <- lexeme (between '"' '"' decimal) <* lexeme (PC.char8 ':')
 212       case Map.lookup fid tmap of
 213         Just (str, ftype) -> between '{' '}' $ do
 214           _ <- lexeme (escapedString) *> lexeme (PC.char8 ':')
 215           val <- lexeme (parseJSONValue ftype)
 216           return $ Just (fid, (str, val))
 217         Nothing -> lexeme parseAnyValue *> return Nothing
 218
 219 parseJSONMap :: ThriftType -> ThriftType -> Parser [(ThriftVal, ThriftVal)]
 220 parseJSONMap kt vt =
 221   ((,) <$> lexeme (parseJSONKey kt) <*>
 222    (lexeme (PC.char8 ':') *> lexeme (parseJSONValue vt))) `sepBy`
 223   lexeme (PC.char8 ',')
 224   where
 225     parseJSONKey T_STRING = parseJSONValue T_STRING
 226     parseJSONKey T_BINARY = parseJSONValue T_BINARY
 227     parseJSONKey kt = PC.char8 '"' *> parseJSONValue kt <* PC.char8 '"'
 228
 229 parseJSONList :: ThriftType -> Parser [ThriftVal]
 230 parseJSONList ty = lexeme (parseJSONValue ty) `sepBy` lexeme (PC.char8 ',')
 231
 232 escapedString :: Parser LBS.ByteString
 233 escapedString = PC.char8 '"' *>
 234                 (LBS.pack <$> P.many' (escapedChar <|> notChar8 '"')) <*
 235                 PC.char8 '"'
 236
 237 base64String :: Parser LBS.ByteString
 238 base64String = PC.char8 '"' *>
 239                (decodeBase64 . LBSC.pack <$> P.many' (PC.notChar '"')) <*
 240                PC.char8 '"'
 241                where
 242                  decodeBase64 b =
 243                    let padded = case (LBS.length b) `mod` 4 of
 244                                   2 -> LBS.append b "=="
 245                                   3 -> LBS.append b "="
 246                                   _ -> b in
 247                    case B64C.decode padded of
 248                      Right s -> s
 249                      Left x -> error x
 250
 251 escapedChar :: Parser Word8
 252 escapedChar = PC.char8 '\\' *> (c2w <$> choice
 253                                 [ '\SOH' <$ P.string "u0001"
 254                                 , '\STX' <$ P.string "u0002"
 255                                 , '\ETX' <$ P.string "u0003"
 256                                 , '\EOT' <$ P.string "u0004"
 257                                 , '\ENQ' <$ P.string "u0005"
 258                                 , '\ACK' <$ P.string "u0006"
 259                                 , '\BEL' <$ P.string "u0007"
 260                                 , '\BS'  <$ P.string "u0008"
 261                                 , '\VT'  <$ P.string "u000b"
 262                                 , '\FF'  <$ P.string "u000c"
 263                                 , '\CR'  <$ P.string "u000d"
 264                                 , '\SO'  <$ P.string "u000e"
 265                                 , '\SI'  <$ P.string "u000f"
 266                                 , '\DLE' <$ P.string "u0010"
 267                                 , '\DC1' <$ P.string "u0011"
 268                                 , '\DC2' <$ P.string "u0012"
 269                                 , '\DC3' <$ P.string "u0013"
 270                                 , '\DC4' <$ P.string "u0014"
 271                                 , '\NAK' <$ P.string "u0015"
 272                                 , '\SYN' <$ P.string "u0016"
 273                                 , '\ETB' <$ P.string "u0017"
 274                                 , '\CAN' <$ P.string "u0018"
 275                                 , '\EM'  <$ P.string "u0019"
 276                                 , '\SUB' <$ P.string "u001a"
 277                                 , '\ESC' <$ P.string "u001b"
 278                                 , '\FS'  <$ P.string "u001c"
 279                                 , '\GS'  <$ P.string "u001d"
 280                                 , '\RS'  <$ P.string "u001e"
 281                                 , '\US'  <$ P.string "u001f"
 282                                 , '\DEL' <$ P.string "u007f"
 283                                 , '\0' <$ PC.char '0'
 284                                 , '\a' <$ PC.char 'a'
 285                                 , '\b' <$ PC.char 'b'
 286                                 , '\f' <$ PC.char 'f'
 287                                 , '\n' <$ PC.char 'n'
 288                                 , '\r' <$ PC.char 'r'
 289                                 , '\t' <$ PC.char 't'
 290                                 , '\v' <$ PC.char 'v'
 291                                 , '\"' <$ PC.char '"'
 292                                 , '\'' <$ PC.char '\''
 293                                 , '\\' <$ PC.char '\\'
 294                                 , '/'  <$ PC.char '/'
 295                                 ])
 296
 297 escape :: LBS.ByteString -> Builder
 298 escape = LBS.foldl' escapeChar mempty
 299   where
 300     escapeChar b w = b <> (B.lazyByteString $ case w2c w of
 301       '\0' -> "\\0"
 302       '\b' -> "\\b"
 303       '\f' -> "\\f"
 304       '\n' -> "\\n"
 305       '\r' -> "\\r"
 306       '\t' -> "\\t"
 307       '\"' -> "\\\""
 308       '\\' -> "\\\\"
 309       '\SOH' -> "\\u0001"
 310       '\STX' -> "\\u0002"
 311       '\ETX' -> "\\u0003"
 312       '\EOT' -> "\\u0004"
 313       '\ENQ' -> "\\u0005"
 314       '\ACK' -> "\\u0006"
 315       '\BEL' -> "\\u0007"
 316       '\VT'  -> "\\u000b"
 317       '\SO'  -> "\\u000e"
 318       '\SI'  -> "\\u000f"
 319       '\DLE' -> "\\u0010"
 320       '\DC1' -> "\\u0011"
 321       '\DC2' -> "\\u0012"
 322       '\DC3' -> "\\u0013"
 323       '\DC4' -> "\\u0014"
 324       '\NAK' -> "\\u0015"
 325       '\SYN' -> "\\u0016"
 326       '\ETB' -> "\\u0017"
 327       '\CAN' -> "\\u0018"
 328       '\EM'  -> "\\u0019"
 329       '\SUB' -> "\\u001a"
 330       '\ESC' -> "\\u001b"
 331       '\FS'  -> "\\u001c"
 332       '\GS'  -> "\\u001d"
 333       '\RS'  -> "\\u001e"
 334       '\US'  -> "\\u001f"
 335       '\DEL' -> "\\u007f"
 336       _ -> LBS.singleton w)
 337
 338 lexeme :: Parser a -> Parser a
 339 lexeme = (<* skipSpace)
 340
 341 notChar8 :: Char -> Parser Word8
 342 notChar8 c = P.satisfy (/= c2w c)
 343
 344 between :: Char -> Char -> Parser a -> Parser a
 345 between a b p = lexeme (PC.char8 a) *> lexeme p <* lexeme (PC.char8 b)
 346
 347 getTypeName :: ThriftType -> Builder
 348 getTypeName ty = B.string8 $ case ty of
 349   T_STRUCT _ -> "rec"
 350   T_MAP _ _  -> "map"
 351   T_LIST _   -> "lst"
 352   T_SET _    -> "set"
 353   T_BOOL     -> "tf"
 354   T_BYTE     -> "i8"
 355   T_I16      -> "i16"
 356   T_I32      -> "i32"
 357   T_I64      -> "i64"
 358   T_DOUBLE   -> "dbl"
 359   T_STRING   -> "str"
 360   T_BINARY   -> "str"
 361   _ -> error "Unrecognized Type"
 362