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