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 26module Thrift.Protocol.SimpleJSON 27 ( module Thrift.Protocol 28 , SimpleJSONProtocol(..) 29 ) where 30 31import Control.Applicative 32import Control.Exception 33import Data.Attoparsec.ByteString as P 34import Data.Attoparsec.ByteString.Char8 as PC 35import Data.Attoparsec.ByteString.Lazy as LP 36import Data.ByteString.Builder as B 37import Data.Functor 38import Data.Int 39import Data.List 40import Data.Maybe (catMaybes) 41#if __GLASGOW_HASKELL__ < 804 42import Data.Monoid 43#endif 44import Data.Text.Lazy.Encoding 45import qualified Data.HashMap.Strict as Map 46import qualified Data.Text.Lazy as LT 47 48import Thrift.Protocol 49import Thrift.Protocol.JSONUtils 50import Thrift.Transport 51import Thrift.Types 52 53-- | The Simple JSON Protocol data uses the standard 'TSimpleJSONProtocol'. 54-- Data is encoded as a JSON 'ByteString' 55data SimpleJSONProtocol t = SimpleJSONProtocol t 56 -- ^ Construct a 'JSONProtocol' with a 'Transport' 57 58version :: Int32 59version = 1 60 61instance Protocol SimpleJSONProtocol where 62 mkProtocol = SimpleJSONProtocol 63 getTransport (SimpleJSONProtocol t) = t 64 65 writeMessage (SimpleJSONProtocol t) (s, ty, sq) = 66 bracket writeMessageBegin writeMessageEnd . const 67 where 68 writeMessageBegin = tWrite t $ toLazyByteString $ 69 "[" <> int32Dec version <> 70 ",\"" <> escape (encodeUtf8 s) <> "\"" <> 71 "," <> intDec (fromEnum ty) <> 72 "," <> int32Dec sq <> 73 "," 74 writeMessageEnd _ = tWrite t "]" 75 readMessage p = bracket readMessageBegin readMessageEnd 76 where 77 readMessageBegin = runParser p $ skipSpace *> do 78 _ver :: Int32 <- lexeme (PC.char8 '[') *> lexeme (signed decimal) 79 bs <- lexeme (PC.char8 ',') *> lexeme escapedString 80 case decodeUtf8' bs of 81 Left _ -> fail "readMessage: invalid text encoding" 82 Right str -> do 83 ty <- toEnum <$> (lexeme (PC.char8 ',') *> 84 lexeme (signed decimal)) 85 seqNum <- lexeme (PC.char8 ',') *> signed decimal 86 return (str, ty, seqNum) 87 readMessageEnd _ = runParser p $ skipSpace *> PC.char8 ']' 88 89 serializeVal _ = toLazyByteString . buildJSONValue 90 deserializeVal _ ty bs = 91 case LP.eitherResult $ LP.parse (parseJSONValue ty) bs of 92 Left s -> error s 93 Right val -> val 94 95 readVal p ty = runParser p $ skipSpace *> parseJSONValue ty 96 97 98-- Writing Functions 99 100buildJSONValue :: ThriftVal -> Builder 101buildJSONValue (TStruct fields) = "{" <> buildJSONStruct fields <> "}" 102buildJSONValue (TMap _ _ entries) = "{" <> buildJSONMap entries <> "}" 103buildJSONValue (TList _ entries) = "[" <> buildJSONList entries <> "]" 104buildJSONValue (TSet _ entries) = "[" <> buildJSONList entries <> "]" 105buildJSONValue (TBool b) = if b then "true" else "false" 106buildJSONValue (TByte b) = int8Dec b 107buildJSONValue (TI16 i) = int16Dec i 108buildJSONValue (TI32 i) = int32Dec i 109buildJSONValue (TI64 i) = int64Dec i 110buildJSONValue (TFloat f) = floatDec f 111buildJSONValue (TDouble d) = doubleDec d 112buildJSONValue (TString s) = "\"" <> escape s <> "\"" 113 114buildJSONStruct :: Map.HashMap Int16 (LT.Text, ThriftVal) -> Builder 115buildJSONStruct = mconcat . intersperse "," . Map.elems . Map.map (\(str,val) -> 116 "\"" <> B.lazyByteString (encodeUtf8 str) <> "\":" <> buildJSONValue val) 117 118buildJSONMap :: [(ThriftVal, ThriftVal)] -> Builder 119buildJSONMap = mconcat . intersperse "," . map buildKV 120 where 121 buildKV (key@(TString _), val) = 122 buildJSONValue key <> ":" <> buildJSONValue val 123 buildKV (key, val) = 124 "\"" <> buildJSONValue key <> "\":" <> buildJSONValue val 125buildJSONList :: [ThriftVal] -> Builder 126buildJSONList = mconcat . intersperse "," . map buildJSONValue 127 128 129-- Reading Functions 130 131parseJSONValue :: ThriftType -> Parser ThriftVal 132parseJSONValue (T_STRUCT tmap) = 133 TStruct <$> (lexeme (PC.char8 '{') *> parseJSONStruct tmap <* PC.char8 '}') 134parseJSONValue (T_MAP kt vt) = 135 TMap kt vt <$> between '{' '}' (parseJSONMap kt vt) 136parseJSONValue (T_LIST ty) = 137 TList ty <$> between '[' ']' (parseJSONList ty) 138parseJSONValue (T_SET ty) = 139 TSet ty <$> between '[' ']' (parseJSONList ty) 140parseJSONValue T_BOOL = 141 (TBool True <$ string "true") <|> (TBool False <$ string "false") 142parseJSONValue T_BYTE = TByte <$> signed decimal 143parseJSONValue T_I16 = TI16 <$> signed decimal 144parseJSONValue T_I32 = TI32 <$> signed decimal 145parseJSONValue T_I64 = TI64 <$> signed decimal 146parseJSONValue T_FLOAT = TFloat . realToFrac <$> double 147parseJSONValue T_DOUBLE = TDouble <$> double 148parseJSONValue T_STRING = TString <$> escapedString 149parseJSONValue T_STOP = fail "parseJSONValue: cannot parse type T_STOP" 150parseJSONValue T_VOID = fail "parseJSONValue: cannot parse type T_VOID" 151 152parseAnyValue :: Parser () 153parseAnyValue = choice $ 154 skipBetween '{' '}' : 155 skipBetween '[' ']' : 156 map (void . parseJSONValue) 157 [ T_BOOL 158 , T_I16 159 , T_I32 160 , T_I64 161 , T_FLOAT 162 , T_DOUBLE 163 , T_STRING 164 ] 165 where 166 skipBetween :: Char -> Char -> Parser () 167 skipBetween a b = between a b $ void $ many $ 168 void (PC.takeWhile1 $ \c -> c /= a && c /= b) 169 <|> skipBetween a b 170 171parseJSONStruct :: TypeMap -> Parser (Map.HashMap Int16 (LT.Text, ThriftVal)) 172parseJSONStruct tmap = Map.fromList . catMaybes <$> parseField 173 `sepBy` lexeme (PC.char8 ',') 174 where 175 parseField = do 176 bs <- lexeme escapedString <* lexeme (PC.char8 ':') 177 case decodeUtf8' bs of 178 Left _ -> fail "parseJSONStruct: invalid key encoding" 179 Right str -> case Map.lookup str tmap of 180 Just (fid, ftype) -> do 181 val <- lexeme (parseJSONValue ftype) 182 return $ Just (fid, (str, val)) 183 Nothing -> lexeme parseAnyValue *> return Nothing 184 185parseJSONMap :: ThriftType -> ThriftType -> Parser [(ThriftVal, ThriftVal)] 186parseJSONMap kt@T_STRING vt = 187 ((,) <$> lexeme (parseJSONValue kt) <*> 188 (lexeme (PC.char8 ':') *> lexeme (parseJSONValue vt))) `sepBy` 189 lexeme (PC.char8 ',') 190parseJSONMap kt vt = 191 ((,) <$> lexeme (PC.char8 '"' *> parseJSONValue kt <* PC.char8 '"') <*> 192 (lexeme (PC.char8 ':') *> lexeme (parseJSONValue vt))) `sepBy` 193 lexeme (PC.char8 ',') 194 195parseJSONList :: ThriftType -> Parser [ThriftVal] 196parseJSONList ty = lexeme (parseJSONValue ty) `sepBy` lexeme (PC.char8 ',') 197