thrift 0.6.0 → 0.9.2
raw patch · 15 files changed
+1343/−555 lines, 15 filesdep +QuickCheckdep +attoparsecdep +containersdep ~HTTPdep ~basedep ~binarynew-uploader
Dependencies added: QuickCheck, attoparsec, containers, hashable, network-uri, split, text, unordered-containers, vector
Dependency ranges changed: HTTP, base, binary, bytestring, network
Files
- LICENSE +0/−202
- src/Thrift.hs +39/−41
- src/Thrift/Arbitraries.hs +61/−0
- src/Thrift/Protocol.hs +95/−145
- src/Thrift/Protocol/Binary.hs +131/−107
- src/Thrift/Protocol/Compact.hs +293/−0
- src/Thrift/Protocol/JSON.hs +325/−0
- src/Thrift/Transport.hs +6/−4
- src/Thrift/Transport/Empty.hs +36/−0
- src/Thrift/Transport/Framed.hs +99/−0
- src/Thrift/Transport/Handle.hs +11/−9
- src/Thrift/Transport/HttpClient.hs +11/−37
- src/Thrift/Transport/IOBuffer.hs +69/−0
- src/Thrift/Types.hs +132/−0
- thrift.cabal +35/−10
− LICENSE
@@ -1,202 +0,0 @@-- Apache License- Version 2.0, January 2004- http://www.apache.org/licenses/-- TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION-- 1. Definitions.-- "License" shall mean the terms and conditions for use, reproduction,- and distribution as defined by Sections 1 through 9 of this document.-- "Licensor" shall mean the copyright owner or entity authorized by- the copyright owner that is granting the License.-- "Legal Entity" shall mean the union of the acting entity and all- other entities that control, are controlled by, or are under common- control with that entity. For the purposes of this definition,- "control" means (i) the power, direct or indirect, to cause the- direction or management of such entity, whether by contract or- otherwise, or (ii) ownership of fifty percent (50%) or more of the- outstanding shares, or (iii) beneficial ownership of such entity.-- "You" (or "Your") shall mean an individual or Legal Entity- exercising permissions granted by this License.-- "Source" form shall mean the preferred form for making modifications,- including but not limited to software source code, documentation- source, and configuration files.-- "Object" form shall mean any form resulting from mechanical- transformation or translation of a Source form, including but- not limited to compiled object code, generated documentation,- and conversions to other media types.-- "Work" shall mean the work of authorship, whether in Source or- Object form, made available under the License, as indicated by a- copyright notice that is included in or attached to the work- (an example is provided in the Appendix below).-- "Derivative Works" shall mean any work, whether in Source or Object- form, that is based on (or derived from) the Work and for which the- editorial revisions, annotations, elaborations, or other modifications- represent, as a whole, an original work of authorship. For the purposes- of this License, Derivative Works shall not include works that remain- separable from, or merely link (or bind by name) to the interfaces of,- the Work and Derivative Works thereof.-- "Contribution" shall mean any work of authorship, including- the original version of the Work and any modifications or additions- to that Work or Derivative Works thereof, that is intentionally- submitted to Licensor for inclusion in the Work by the copyright owner- or by an individual or Legal Entity authorized to submit on behalf of- the copyright owner. For the purposes of this definition, "submitted"- means any form of electronic, verbal, or written communication sent- to the Licensor or its representatives, including but not limited to- communication on electronic mailing lists, source code control systems,- and issue tracking systems that are managed by, or on behalf of, the- Licensor for the purpose of discussing and improving the Work, but- excluding communication that is conspicuously marked or otherwise- designated in writing by the copyright owner as "Not a Contribution."-- "Contributor" shall mean Licensor and any individual or Legal Entity- on behalf of whom a Contribution has been received by Licensor and- subsequently incorporated within the Work.-- 2. Grant of Copyright License. Subject to the terms and conditions of- this License, each Contributor hereby grants to You a perpetual,- worldwide, non-exclusive, no-charge, royalty-free, irrevocable- copyright license to reproduce, prepare Derivative Works of,- publicly display, publicly perform, sublicense, and distribute the- Work and such Derivative Works in Source or Object form.-- 3. Grant of Patent License. Subject to the terms and conditions of- this License, each Contributor hereby grants to You a perpetual,- worldwide, non-exclusive, no-charge, royalty-free, irrevocable- (except as stated in this section) patent license to make, have made,- use, offer to sell, sell, import, and otherwise transfer the Work,- where such license applies only to those patent claims licensable- by such Contributor that are necessarily infringed by their- Contribution(s) alone or by combination of their Contribution(s)- with the Work to which such Contribution(s) was submitted. If You- institute patent litigation against any entity (including a- cross-claim or counterclaim in a lawsuit) alleging that the Work- or a Contribution incorporated within the Work constitutes direct- or contributory patent infringement, then any patent licenses- granted to You under this License for that Work shall terminate- as of the date such litigation is filed.-- 4. Redistribution. You may reproduce and distribute copies of the- Work or Derivative Works thereof in any medium, with or without- modifications, and in Source or Object form, provided that You- meet the following conditions:-- (a) You must give any other recipients of the Work or- Derivative Works a copy of this License; and-- (b) You must cause any modified files to carry prominent notices- stating that You changed the files; and-- (c) You must retain, in the Source form of any Derivative Works- that You distribute, all copyright, patent, trademark, and- attribution notices from the Source form of the Work,- excluding those notices that do not pertain to any part of- the Derivative Works; and-- (d) If the Work includes a "NOTICE" text file as part of its- distribution, then any Derivative Works that You distribute must- include a readable copy of the attribution notices contained- within such NOTICE file, excluding those notices that do not- pertain to any part of the Derivative Works, in at least one- of the following places: within a NOTICE text file distributed- as part of the Derivative Works; within the Source form or- documentation, if provided along with the Derivative Works; or,- within a display generated by the Derivative Works, if and- wherever such third-party notices normally appear. The contents- of the NOTICE file are for informational purposes only and- do not modify the License. You may add Your own attribution- notices within Derivative Works that You distribute, alongside- or as an addendum to the NOTICE text from the Work, provided- that such additional attribution notices cannot be construed- as modifying the License.-- You may add Your own copyright statement to Your modifications and- may provide additional or different license terms and conditions- for use, reproduction, or distribution of Your modifications, or- for any such Derivative Works as a whole, provided Your use,- reproduction, and distribution of the Work otherwise complies with- the conditions stated in this License.-- 5. Submission of Contributions. Unless You explicitly state otherwise,- any Contribution intentionally submitted for inclusion in the Work- by You to the Licensor shall be under the terms and conditions of- this License, without any additional terms or conditions.- Notwithstanding the above, nothing herein shall supersede or modify- the terms of any separate license agreement you may have executed- with Licensor regarding such Contributions.-- 6. Trademarks. This License does not grant permission to use the trade- names, trademarks, service marks, or product names of the Licensor,- except as required for reasonable and customary use in describing the- origin of the Work and reproducing the content of the NOTICE file.-- 7. Disclaimer of Warranty. Unless required by applicable law or- agreed to in writing, Licensor provides the Work (and each- Contributor provides its Contributions) on an "AS IS" BASIS,- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or- implied, including, without limitation, any warranties or conditions- of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A- PARTICULAR PURPOSE. You are solely responsible for determining the- appropriateness of using or redistributing the Work and assume any- risks associated with Your exercise of permissions under this License.-- 8. Limitation of Liability. In no event and under no legal theory,- whether in tort (including negligence), contract, or otherwise,- unless required by applicable law (such as deliberate and grossly- negligent acts) or agreed to in writing, shall any Contributor be- liable to You for damages, including any direct, indirect, special,- incidental, or consequential damages of any character arising as a- result of this License or out of the use or inability to use the- Work (including but not limited to damages for loss of goodwill,- work stoppage, computer failure or malfunction, or any and all- other commercial damages or losses), even if such Contributor- has been advised of the possibility of such damages.-- 9. Accepting Warranty or Additional Liability. While redistributing- the Work or Derivative Works thereof, You may choose to offer,- and charge a fee for, acceptance of support, warranty, indemnity,- or other liability obligations and/or rights consistent with this- License. However, in accepting such obligations, You may act only- on Your own behalf and on Your sole responsibility, not on behalf- of any other Contributor, and only if You agree to indemnify,- defend, and hold each Contributor harmless for any liability- incurred by, or claims asserted against, such Contributor by reason- of your accepting any such warranty or additional liability.-- END OF TERMS AND CONDITIONS-- APPENDIX: How to apply the Apache License to your work.-- To apply the Apache License to your work, attach the following- boilerplate notice, with the fields enclosed by brackets "[]"- replaced with your own identifying information. (Don't include- the brackets!) The text should be enclosed in the appropriate- comment syntax for the file format. We also recommend that a- file or class name and description of purpose be included on the- same "printed page" as the copyright notice for easier- identification within third-party archives.-- Copyright [yyyy] [name of copyright owner]-- Licensed under the Apache License, Version 2.0 (the "License");- you may not use this file except in compliance with the License.- You may obtain a copy of the License at-- http://www.apache.org/licenses/LICENSE-2.0-- Unless required by applicable law or agreed to in writing, software- distributed under the License is distributed on an "AS IS" BASIS,- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.- See the License for the specific language governing permissions and- limitations under the License.
src/Thrift.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -- -- Licensed to the Apache Software Foundation (ASF) under one@@ -30,14 +30,17 @@ , ThriftException(..) ) where -import Control.Monad ( when ) import Control.Exception +import Data.Int+import Data.Text.Lazy ( Text, pack, unpack )+import Data.Text.Lazy.Encoding import Data.Typeable ( Typeable )+import qualified Data.HashMap.Strict as Map -import Thrift.Transport import Thrift.Protocol-+import Thrift.Transport+import Thrift.Types data ThriftException = ThriftException deriving ( Show, Typeable )@@ -50,6 +53,11 @@ | AE_WRONG_METHOD_NAME | AE_BAD_SEQUENCE_ID | AE_MISSING_RESULT+ | AE_INTERNAL_ERROR+ | AE_PROTOCOL_ERROR+ | AE_INVALID_TRANSFORM+ | AE_INVALID_PROTOCOL+ | AE_UNSUPPORTED_CLIENT_TYPE deriving ( Eq, Show, Typeable ) instance Enum AppExnType where@@ -59,6 +67,11 @@ toEnum 3 = AE_WRONG_METHOD_NAME toEnum 4 = AE_BAD_SEQUENCE_ID toEnum 5 = AE_MISSING_RESULT+ toEnum 6 = AE_INTERNAL_ERROR+ toEnum 7 = AE_PROTOCOL_ERROR+ toEnum 8 = AE_INVALID_TRANSFORM+ toEnum 9 = AE_INVALID_PROTOCOL+ toEnum 10 = AE_UNSUPPORTED_CLIENT_TYPE toEnum t = error $ "Invalid AppExnType " ++ show t fromEnum AE_UNKNOWN = 0@@ -67,50 +80,35 @@ fromEnum AE_WRONG_METHOD_NAME = 3 fromEnum AE_BAD_SEQUENCE_ID = 4 fromEnum AE_MISSING_RESULT = 5+ fromEnum AE_INTERNAL_ERROR = 6+ fromEnum AE_PROTOCOL_ERROR = 7+ fromEnum AE_INVALID_TRANSFORM = 8+ fromEnum AE_INVALID_PROTOCOL = 9+ fromEnum AE_UNSUPPORTED_CLIENT_TYPE = 10 data AppExn = AppExn { ae_type :: AppExnType, ae_message :: String } deriving ( Show, Typeable ) instance Exception AppExn writeAppExn :: (Protocol p, Transport t) => p t -> AppExn -> IO ()-writeAppExn pt ae = do- writeStructBegin pt "TApplicationException"-- when (ae_message ae /= "") $ do- writeFieldBegin pt ("message", T_STRING , 1)- writeString pt (ae_message ae)- writeFieldEnd pt-- writeFieldBegin pt ("type", T_I32, 2);- writeI32 pt (fromIntegral $ fromEnum (ae_type ae))- writeFieldEnd pt- writeFieldStop pt- writeStructEnd pt+writeAppExn pt ae = writeVal pt $ TStruct $ Map.fromList+ [ (1, ("message", TString $ encodeUtf8 $ pack $ ae_message ae))+ , (2, ("type", TI32 $ fromIntegral $ fromEnum (ae_type ae)))+ ] readAppExn :: (Protocol p, Transport t) => p t -> IO AppExn readAppExn pt = do- _ <- readStructBegin pt- record <- readAppExnFields pt (AppExn {ae_type = undefined, ae_message = undefined})- readStructEnd pt- return record--readAppExnFields :: forall (a :: * -> *) t. (Protocol a, Transport t) => a t -> AppExn -> IO AppExn -readAppExnFields pt record = do- (_, ft, tag) <- readFieldBegin pt- if ft == T_STOP- then return record- else case tag of- 1 -> if ft == T_STRING then- do s <- readString pt- readAppExnFields pt record{ae_message = s}- else do skip pt ft- readAppExnFields pt record- 2 -> if ft == T_I32 then- do i <- readI32 pt- readAppExnFields pt record{ae_type = (toEnum $ fromIntegral i)}- else do skip pt ft- readAppExnFields pt record- _ -> do skip pt ft- readFieldEnd pt- readAppExnFields pt record+ let typemap = Map.fromList [(1,("message",T_STRING)),(2,("type",T_I32))]+ TStruct fields <- readVal pt $ T_STRUCT typemap+ return $ readAppExnFields fields +readAppExnFields :: Map.HashMap Int16 (Text, ThriftVal) -> AppExn+readAppExnFields fields = AppExn{+ ae_message = maybe undefined unwrapMessage $ Map.lookup 1 fields,+ ae_type = maybe undefined unwrapType $ Map.lookup 2 fields+ }+ where+ unwrapMessage (_, TString s) = unpack $ decodeUtf8 s+ unwrapMessage _ = undefined+ unwrapType (_, TI32 i) = toEnum $ fromIntegral i+ unwrapType _ = undefined
+ src/Thrift/Arbitraries.hs view
@@ -0,0 +1,61 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Thrift.Arbitraries where++import Data.Bits()++import Test.QuickCheck.Arbitrary++import Control.Applicative ((<$>))+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Vector as Vector+import qualified Data.Text.Lazy as Text+import qualified Data.HashSet as HSet+import qualified Data.HashMap.Strict as HMap+import Data.Hashable (Hashable)++import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as BS++-- String has an Arbitrary instance already+-- Bool has an Arbitrary instance already+-- A Thrift 'list' is a Vector.++instance Arbitrary ByteString where+ arbitrary = BS.pack . filter (/= 0) <$> arbitrary++instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map k v) where+ arbitrary = Map.fromList <$> arbitrary++instance (Ord k, Arbitrary k) => Arbitrary (Set.Set k) where+ arbitrary = Set.fromList <$> arbitrary++instance (Arbitrary k) => Arbitrary (Vector.Vector k) where+ arbitrary = Vector.fromList <$> arbitrary++instance Arbitrary Text.Text where+ arbitrary = Text.pack . filter (/= '\0') <$> arbitrary++instance (Eq k, Hashable k, Arbitrary k) => Arbitrary (HSet.HashSet k) where+ arbitrary = HSet.fromList <$> arbitrary++instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) =>+ Arbitrary (HMap.HashMap k v) where+ arbitrary = HMap.fromList <$> arbitrary++{-+ To handle Thrift 'enum' we would ideally use something like:++instance (Enum a, Bounded a) => Arbitrary a+ where arbitrary = elements (enumFromTo minBound maxBound)++Unfortunately this doesn't play nicely with the type system.+Instead we'll generate an arbitrary instance along with the code.+-}++{-+ There might be some way to introspect on the Haskell structure of a+ Thrift 'struct' or 'exception' but generating the code directly is simpler.+-}
src/Thrift/Protocol.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-} -- -- Licensed to the Apache Software Foundation (ASF) under one -- or more contributor license agreements. See the NOTICE file@@ -20,166 +22,58 @@ module Thrift.Protocol ( Protocol(..)- , skip- , MessageType(..)- , ThriftType(..) , ProtocolExn(..) , ProtocolExnType(..)+ , getTypeOf+ , runParser+ , versionMask+ , version1+ , bsToDouble ) where -import Control.Monad ( replicateM_, unless ) import Control.Exception+import Data.Attoparsec.ByteString+import Data.Bits+import Data.ByteString.Lazy (ByteString, toStrict)+import Data.ByteString.Unsafe+import Data.Functor ((<$>)) import Data.Int-import Data.Typeable ( Typeable )-import Data.ByteString.Lazy+import Data.Monoid (mempty)+import Data.Text.Lazy (Text)+import Data.Typeable (Typeable)+import Data.Word+import Foreign.Ptr (castPtr)+import Foreign.Storable (Storable, peek, poke)+import System.IO.Unsafe+import qualified Data.ByteString as BS+import qualified Data.HashMap.Strict as Map +import Thrift.Types import Thrift.Transport --data ThriftType- = T_STOP- | T_VOID- | T_BOOL- | T_BYTE- | T_DOUBLE- | T_I16- | T_I32- | T_I64- | T_STRING- | T_STRUCT- | T_MAP- | T_SET- | T_LIST- deriving ( Eq )--instance Enum ThriftType where- fromEnum T_STOP = 0- fromEnum T_VOID = 1- fromEnum T_BOOL = 2- fromEnum T_BYTE = 3- fromEnum T_DOUBLE = 4- fromEnum T_I16 = 6- fromEnum T_I32 = 8- fromEnum T_I64 = 10- fromEnum T_STRING = 11- fromEnum T_STRUCT = 12- fromEnum T_MAP = 13- fromEnum T_SET = 14- fromEnum T_LIST = 15-- toEnum 0 = T_STOP- toEnum 1 = T_VOID- toEnum 2 = T_BOOL- toEnum 3 = T_BYTE- toEnum 4 = T_DOUBLE- toEnum 6 = T_I16- toEnum 8 = T_I32- toEnum 10 = T_I64- toEnum 11 = T_STRING- toEnum 12 = T_STRUCT- toEnum 13 = T_MAP- toEnum 14 = T_SET- toEnum 15 = T_LIST- toEnum t = error $ "Invalid ThriftType " ++ show t--data MessageType- = M_CALL- | M_REPLY- | M_EXCEPTION- deriving ( Eq )--instance Enum MessageType where- fromEnum M_CALL = 1- fromEnum M_REPLY = 2- fromEnum M_EXCEPTION = 3-- toEnum 1 = M_CALL- toEnum 2 = M_REPLY- toEnum 3 = M_EXCEPTION- toEnum t = error $ "Invalid MessageType " ++ show t+versionMask :: Int32+versionMask = fromIntegral (0xffff0000 :: Word32) +version1 :: Int32+version1 = fromIntegral (0x80010000 :: Word32) class Protocol a where- getTransport :: Transport t => a t -> t-- writeMessageBegin :: Transport t => a t -> (String, MessageType, Int32) -> IO ()- writeMessageEnd :: Transport t => a t -> IO ()-- writeStructBegin :: Transport t => a t -> String -> IO ()- writeStructEnd :: Transport t => a t -> IO ()- writeFieldBegin :: Transport t => a t -> (String, ThriftType, Int16) -> IO ()- writeFieldEnd :: Transport t => a t -> IO ()- writeFieldStop :: Transport t => a t -> IO ()- writeMapBegin :: Transport t => a t -> (ThriftType, ThriftType, Int32) -> IO ()- writeMapEnd :: Transport t => a t -> IO ()- writeListBegin :: Transport t => a t -> (ThriftType, Int32) -> IO ()- writeListEnd :: Transport t => a t -> IO ()- writeSetBegin :: Transport t => a t -> (ThriftType, Int32) -> IO ()- writeSetEnd :: Transport t => a t -> IO ()-- writeBool :: Transport t => a t -> Bool -> IO ()- writeByte :: Transport t => a t -> Int8 -> IO ()- writeI16 :: Transport t => a t -> Int16 -> IO ()- writeI32 :: Transport t => a t -> Int32 -> IO ()- writeI64 :: Transport t => a t -> Int64 -> IO ()- writeDouble :: Transport t => a t -> Double -> IO ()- writeString :: Transport t => a t -> String -> IO ()- writeBinary :: Transport t => a t -> ByteString -> IO ()--- readMessageBegin :: Transport t => a t -> IO (String, MessageType, Int32)- readMessageEnd :: Transport t => a t -> IO ()-- readStructBegin :: Transport t => a t -> IO String- readStructEnd :: Transport t => a t -> IO ()- readFieldBegin :: Transport t => a t -> IO (String, ThriftType, Int16)- readFieldEnd :: Transport t => a t -> IO ()- readMapBegin :: Transport t => a t -> IO (ThriftType, ThriftType, Int32)- readMapEnd :: Transport t => a t -> IO ()- readListBegin :: Transport t => a t -> IO (ThriftType, Int32)- readListEnd :: Transport t => a t -> IO ()- readSetBegin :: Transport t => a t -> IO (ThriftType, Int32)- readSetEnd :: Transport t => a t -> IO ()-- readBool :: Transport t => a t -> IO Bool- readByte :: Transport t => a t -> IO Int8- readI16 :: Transport t => a t -> IO Int16- readI32 :: Transport t => a t -> IO Int32- readI64 :: Transport t => a t -> IO Int64- readDouble :: Transport t => a t -> IO Double- readString :: Transport t => a t -> IO String- readBinary :: Transport t => a t -> IO ByteString---skip :: (Protocol p, Transport t) => p t -> ThriftType -> IO ()-skip _ T_STOP = return ()-skip _ T_VOID = return ()-skip p T_BOOL = readBool p >> return ()-skip p T_BYTE = readByte p >> return ()-skip p T_I16 = readI16 p >> return ()-skip p T_I32 = readI32 p >> return ()-skip p T_I64 = readI64 p >> return ()-skip p T_DOUBLE = readDouble p >> return ()-skip p T_STRING = readString p >> return ()-skip p T_STRUCT = do _ <- readStructBegin p- skipFields p- readStructEnd p-skip p T_MAP = do (k, v, s) <- readMapBegin p- replicateM_ (fromIntegral s) (skip p k >> skip p v)- readMapEnd p-skip p T_SET = do (t, n) <- readSetBegin p- replicateM_ (fromIntegral n) (skip p t)- readSetEnd p-skip p T_LIST = do (t, n) <- readListBegin p- replicateM_ (fromIntegral n) (skip p t)- readListEnd p+ getTransport :: Transport t => a t -> t + writeMessageBegin :: Transport t => a t -> (Text, MessageType, Int32) -> IO ()+ writeMessageEnd :: Transport t => a t -> IO ()+ writeMessageEnd _ = return ()+ + readMessageBegin :: Transport t => a t -> IO (Text, MessageType, Int32)+ readMessageEnd :: Transport t => a t -> IO ()+ readMessageEnd _ = return () -skipFields :: (Protocol p, Transport t) => p t -> IO ()-skipFields p = do- (_, t, _) <- readFieldBegin p- unless (t == T_STOP) (skip p t >> readFieldEnd p >> skipFields p)+ serializeVal :: Transport t => a t -> ThriftVal -> ByteString+ deserializeVal :: Transport t => a t -> ThriftType -> ByteString -> ThriftVal + writeVal :: Transport t => a t -> ThriftVal -> IO ()+ writeVal p = tWrite (getTransport p) . serializeVal p+ readVal :: Transport t => a t -> ThriftType -> IO ThriftVal data ProtocolExnType = PE_UNKNOWN@@ -187,8 +81,64 @@ | PE_NEGATIVE_SIZE | PE_SIZE_LIMIT | PE_BAD_VERSION+ | PE_NOT_IMPLEMENTED+ | PE_MISSING_REQUIRED_FIELD deriving ( Eq, Show, Typeable ) data ProtocolExn = ProtocolExn ProtocolExnType String deriving ( Show, Typeable ) instance Exception ProtocolExn++getTypeOf :: ThriftVal -> ThriftType+getTypeOf v = case v of+ TStruct{} -> T_STRUCT Map.empty+ TMap{} -> T_MAP T_VOID T_VOID+ TList{} -> T_LIST T_VOID+ TSet{} -> T_SET T_VOID+ TBool{} -> T_BOOL+ TByte{} -> T_BYTE+ TI16{} -> T_I16+ TI32{} -> T_I32+ TI64{} -> T_I64+ TString{} -> T_STRING+ TDouble{} -> T_DOUBLE++runParser :: (Protocol p, Transport t, Show a) => p t -> Parser a -> IO a+runParser prot p = refill >>= getResult . parse p+ where+ refill = handle handleEOF $ toStrict <$> tRead (getTransport prot) 1+ getResult (Done _ a) = return a+ getResult (Partial k) = refill >>= getResult . k+ getResult f = throw $ ProtocolExn PE_INVALID_DATA (show f)++handleEOF :: SomeException -> IO BS.ByteString+handleEOF = const $ return mempty++-- | Converts a ByteString to a Floating point number+-- The ByteString is assumed to be encoded in network order (Big Endian)+-- therefore the behavior of this function varies based on whether the local+-- machine is big endian or little endian.+bsToDouble :: BS.ByteString -> Double+bsToDouble bs = unsafeDupablePerformIO $ unsafeUseAsCString bs castBs+ where+#if __BYTE_ORDER == __LITTLE_ENDIAN+ castBs chrPtr = do+ w <- peek (castPtr chrPtr)+ poke (castPtr chrPtr) (byteSwap w)+ peek (castPtr chrPtr)+#else+ castBs = peek . castPtr+#endif++#if __BYTE_ORDER == __LITTLE_ENDIAN+-- | Swap endianness of a 64-bit word+byteSwap :: Word64 -> Word64+byteSwap w = (w `shiftL` 56 .&. 0xFF00000000000000) .|.+ (w `shiftL` 40 .&. 0x00FF000000000000) .|.+ (w `shiftL` 24 .&. 0x0000FF0000000000) .|.+ (w `shiftL` 8 .&. 0x000000FF00000000) .|.+ (w `shiftR` 8 .&. 0x00000000FF000000) .|.+ (w `shiftR` 24 .&. 0x0000000000FF0000) .|.+ (w `shiftR` 40 .&. 0x000000000000FF00) .|.+ (w `shiftR` 56 .&. 0x00000000000000FF)+#endif
src/Thrift/Protocol/Binary.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE MagicHash #-} -- -- Licensed to the Apache Software Foundation (ASF) under one -- or more contributor license agreements. See the NOTICE file@@ -19,143 +17,169 @@ -- under the License. -- +{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module Thrift.Protocol.Binary ( module Thrift.Protocol , BinaryProtocol(..) ) where import Control.Exception ( throw )-import Control.Monad ( liftM )--import qualified Data.Binary+import Control.Monad import Data.Bits+import Data.ByteString.Lazy.Builder+import Data.Functor import Data.Int--import GHC.Exts-import GHC.Word+import Data.Monoid+import Data.Text.Lazy.Encoding ( decodeUtf8, encodeUtf8 ) import Thrift.Protocol import Thrift.Transport+import Thrift.Types +import qualified Data.Attoparsec.ByteString as P+import qualified Data.Attoparsec.ByteString.Lazy as LP+import qualified Data.Binary as Binary import qualified Data.ByteString.Lazy as LBS-import qualified Data.ByteString.Lazy.Char8 as LBSChar8--version_mask :: Int32-version_mask = 0xffff0000--version_1 :: Int32-version_1 = 0x80010000--data BinaryProtocol a = Transport a => BinaryProtocol a+import qualified Data.HashMap.Strict as Map+import qualified Data.Text.Lazy as LT +data BinaryProtocol a = BinaryProtocol a +-- NOTE: Reading and Writing functions rely on Builders and Data.Binary to+-- encode and decode data. Data.Binary assumes that the binary values it is+-- encoding to and decoding from are in BIG ENDIAN format, and converts the+-- endianness as necessary to match the local machine. instance Protocol BinaryProtocol where getTransport (BinaryProtocol t) = t - writeMessageBegin p (n, t, s) = do- writeI32 p (version_1 .|. (fromIntegral $ fromEnum t))- writeString p n- writeI32 p s- writeMessageEnd _ = return ()+ writeMessageBegin p (n, t, s) = tWrite (getTransport p) $ toLazyByteString $+ buildBinaryValue (TI32 (version1 .|. fromIntegral (fromEnum t))) <>+ buildBinaryValue (TString $ encodeUtf8 n) <>+ buildBinaryValue (TI32 s) - writeStructBegin _ _ = return ()- writeStructEnd _ = return ()- writeFieldBegin p (_, t, i) = writeType p t >> writeI16 p i- writeFieldEnd _ = return ()- writeFieldStop p = writeType p T_STOP- writeMapBegin p (k, v, n) = writeType p k >> writeType p v >> writeI32 p n- writeMapEnd _ = return ()- writeListBegin p (t, n) = writeType p t >> writeI32 p n- writeListEnd _ = return ()- writeSetBegin p (t, n) = writeType p t >> writeI32 p n- writeSetEnd _ = return ()+ readMessageBegin p = runParser p $ do+ TI32 ver <- parseBinaryValue T_I32+ if ver .&. versionMask /= version1+ then throw $ ProtocolExn PE_BAD_VERSION "Missing version identifier"+ else do+ TString s <- parseBinaryValue T_STRING+ TI32 sz <- parseBinaryValue T_I32+ return (decodeUtf8 s, toEnum $ fromIntegral $ ver .&. 0xFF, sz) - writeBool p b = tWrite (getTransport p) $ LBS.singleton $ toEnum $ if b then 1 else 0- writeByte p b = tWrite (getTransport p) $ Data.Binary.encode b- writeI16 p b = tWrite (getTransport p) $ Data.Binary.encode b- writeI32 p b = tWrite (getTransport p) $ Data.Binary.encode b- writeI64 p b = tWrite (getTransport p) $ Data.Binary.encode b- writeDouble p d = writeI64 p (fromIntegral $ floatBits d)- writeString p s = writeI32 p (fromIntegral $ length s) >> tWrite (getTransport p) (LBSChar8.pack s)- writeBinary p s = writeI32 p (fromIntegral $ LBS.length s) >> tWrite (getTransport p) s+ serializeVal _ = toLazyByteString . buildBinaryValue+ deserializeVal _ ty bs =+ case LP.eitherResult $ LP.parse (parseBinaryValue ty) bs of+ Left s -> error s+ Right val -> val - readMessageBegin p = do- ver <- readI32 p- if (ver .&. version_mask /= version_1)- then throw $ ProtocolExn PE_BAD_VERSION "Missing version identifier"- else do- s <- readString p- sz <- readI32 p- return (s, toEnum $ fromIntegral $ ver .&. 0xFF, sz)- readMessageEnd _ = return ()- readStructBegin _ = return ""- readStructEnd _ = return ()- readFieldBegin p = do- t <- readType p- n <- if t /= T_STOP then readI16 p else return 0- return ("", t, n)- readFieldEnd _ = return ()- readMapBegin p = do- kt <- readType p- vt <- readType p- n <- readI32 p- return (kt, vt, n)- readMapEnd _ = return ()- readListBegin p = do- t <- readType p- n <- readI32 p- return (t, n)- readListEnd _ = return ()- readSetBegin p = do- t <- readType p- n <- readI32 p- return (t, n)- readSetEnd _ = return ()+ readVal p = runParser p . parseBinaryValue - readBool p = (== 1) `fmap` readByte p+-- | Writing Functions+buildBinaryValue :: ThriftVal -> Builder+buildBinaryValue (TStruct fields) = buildBinaryStruct fields <> buildType T_STOP+buildBinaryValue (TMap ky vt entries) =+ buildType ky <>+ buildType vt <>+ int32BE (fromIntegral (length entries)) <>+ buildBinaryMap entries+buildBinaryValue (TList ty entries) =+ buildType ty <>+ int32BE (fromIntegral (length entries)) <>+ buildBinaryList entries+buildBinaryValue (TSet ty entries) =+ buildType ty <>+ int32BE (fromIntegral (length entries)) <>+ buildBinaryList entries+buildBinaryValue (TBool b) =+ word8 $ toEnum $ if b then 1 else 0+buildBinaryValue (TByte b) = int8 b+buildBinaryValue (TI16 i) = int16BE i+buildBinaryValue (TI32 i) = int32BE i+buildBinaryValue (TI64 i) = int64BE i+buildBinaryValue (TDouble d) = doubleBE d+buildBinaryValue (TString s) = int32BE len <> lazyByteString s+ where+ len :: Int32 = fromIntegral (LBS.length s) - readByte p = do- bs <- tReadAll (getTransport p) 1- return $ Data.Binary.decode bs+buildBinaryStruct :: Map.HashMap Int16 (LT.Text, ThriftVal) -> Builder+buildBinaryStruct = Map.foldrWithKey combine mempty+ where+ combine fid (_,val) s =+ buildTypeOf val <> int16BE fid <> buildBinaryValue val <> s - readI16 p = do- bs <- tReadAll (getTransport p) 2- return $ Data.Binary.decode bs+buildBinaryMap :: [(ThriftVal, ThriftVal)] -> Builder+buildBinaryMap = foldl combine mempty+ where+ combine s (key, val) = s <> buildBinaryValue key <> buildBinaryValue val - readI32 p = do- bs <- tReadAll (getTransport p) 4- return $ Data.Binary.decode bs+buildBinaryList :: [ThriftVal] -> Builder+buildBinaryList = foldr (mappend . buildBinaryValue) mempty - readI64 p = do- bs <- tReadAll (getTransport p) 8- return $ Data.Binary.decode bs+-- | Reading Functions+parseBinaryValue :: ThriftType -> P.Parser ThriftVal+parseBinaryValue (T_STRUCT _) = TStruct <$> parseBinaryStruct+parseBinaryValue (T_MAP _ _) = do+ kt <- parseType+ vt <- parseType+ n <- Binary.decode . LBS.fromStrict <$> P.take 4+ TMap kt vt <$> parseBinaryMap kt vt n+parseBinaryValue (T_LIST _) = do+ t <- parseType+ n <- Binary.decode . LBS.fromStrict <$> P.take 4+ TList t <$> parseBinaryList t n+parseBinaryValue (T_SET _) = do+ t <- parseType+ n <- Binary.decode . LBS.fromStrict <$> P.take 4+ TSet t <$> parseBinaryList t n+parseBinaryValue T_BOOL = TBool . (/=0) <$> P.anyWord8+parseBinaryValue T_BYTE = TByte . Binary.decode . LBS.fromStrict <$> P.take 1+parseBinaryValue T_I16 = TI16 . Binary.decode . LBS.fromStrict <$> P.take 2+parseBinaryValue T_I32 = TI32 . Binary.decode . LBS.fromStrict <$> P.take 4+parseBinaryValue T_I64 = TI64 . Binary.decode . LBS.fromStrict <$> P.take 8+parseBinaryValue T_DOUBLE = TDouble . bsToDouble <$> P.take 8+parseBinaryValue T_STRING = do+ i :: Int32 <- Binary.decode . LBS.fromStrict <$> P.take 4+ TString . LBS.fromStrict <$> P.take (fromIntegral i)+parseBinaryValue ty = error $ "Cannot read value of type " ++ show ty - readDouble p = do- bs <- readI64 p- return $ floatOfBits $ fromIntegral bs+parseBinaryStruct :: P.Parser (Map.HashMap Int16 (LT.Text, ThriftVal))+parseBinaryStruct = Map.fromList <$> P.manyTill parseField (matchType T_STOP)+ where+ parseField = do+ t <- parseType+ n <- Binary.decode . LBS.fromStrict <$> P.take 2+ v <- parseBinaryValue t+ return (n, ("", v)) - readString p = do- i <- readI32 p- LBSChar8.unpack `liftM` tReadAll (getTransport p) (fromIntegral i)+parseBinaryMap :: ThriftType -> ThriftType -> Int32 -> P.Parser [(ThriftVal, ThriftVal)]+parseBinaryMap kt vt n | n <= 0 = return []+ | otherwise = do+ k <- parseBinaryValue kt+ v <- parseBinaryValue vt+ ((k,v) :) <$> parseBinaryMap kt vt (n-1) - readBinary p = do- i <- readI32 p- tReadAll (getTransport p) (fromIntegral i)+parseBinaryList :: ThriftType -> Int32 -> P.Parser [ThriftVal]+parseBinaryList ty n | n <= 0 = return []+ | otherwise = liftM2 (:) (parseBinaryValue ty)+ (parseBinaryList ty (n-1)) --- | Write a type as a byte-writeType :: (Protocol p, Transport t) => p t -> ThriftType -> IO ()-writeType p t = writeByte p (fromIntegral $ fromEnum t) --- | Read a byte as though it were a ThriftType-readType :: (Protocol p, Transport t) => p t -> IO ThriftType-readType p = do- b <- readByte p- return $ toEnum $ fromIntegral b+-- | Write a type as a byte+buildType :: ThriftType -> Builder+buildType t = word8 $ fromIntegral $ fromEnum t -floatBits :: Double -> Word64-floatBits (D# d#) = W64# (unsafeCoerce# d#)+-- | Write type of a ThriftVal as a byte+buildTypeOf :: ThriftVal -> Builder+buildTypeOf = buildType . getTypeOf -floatOfBits :: Word64 -> Double-floatOfBits (W64# b#) = D# (unsafeCoerce# b#)+-- | Read a byte as though it were a ThriftType+parseType :: P.Parser ThriftType+parseType = toEnum . fromIntegral <$> P.anyWord8 +matchType :: ThriftType -> P.Parser ThriftType+matchType t = t <$ P.word8 (fromIntegral $ fromEnum t)
+ src/Thrift/Protocol/Compact.hs view
@@ -0,0 +1,293 @@+--+-- Licensed to the Apache Software Foundation (ASF) under one+-- or more contributor license agreements. See the NOTICE file+-- distributed with this work for additional information+-- regarding copyright ownership. The ASF licenses this file+-- to you under the Apache License, Version 2.0 (the+-- "License"); you may not use this file except in compliance+-- with the License. You may obtain a copy of the License at+--+-- http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing,+-- software distributed under the License is distributed on an+-- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY+-- KIND, either express or implied. See the License for the+-- specific language governing permissions and limitations+-- under the License.+--++{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Thrift.Protocol.Compact+ ( module Thrift.Protocol+ , CompactProtocol(..)+ ) where++import Control.Applicative+import Control.Exception ( throw )+import Control.Monad+import Data.Attoparsec.ByteString as P+import Data.Attoparsec.ByteString.Lazy as LP+import Data.Bits+import Data.ByteString.Lazy.Builder as B+import Data.Int+import Data.List as List+import Data.Monoid+import Data.Word+import Data.Text.Lazy.Encoding ( decodeUtf8, encodeUtf8 )++import Thrift.Protocol hiding (versionMask)+import Thrift.Transport+import Thrift.Types++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.HashMap.Strict as Map+import qualified Data.Text.Lazy as LT++-- | the Compact Protocol implements the standard Thrift 'TCompactProcotol'+-- which is similar to the 'TBinaryProtocol', but takes less space on the wire.+-- Integral types are encoded using as varints.+data CompactProtocol a = CompactProtocol a+ -- ^ Constuct a 'CompactProtocol' with a 'Transport'++protocolID, version, typeMask :: Int8+protocolID = 0x82 -- 1000 0010+version = 0x01+versionMask = 0x1f -- 0001 1111+typeMask = 0xe0 -- 1110 0000+typeBits = 0x07 -- 0000 0111+typeShiftAmount :: Int+typeShiftAmount = 5+++instance Protocol CompactProtocol where+ getTransport (CompactProtocol t) = t++ writeMessageBegin p (n, t, s) = tWrite (getTransport p) $ toLazyByteString $+ B.int8 protocolID <>+ B.int8 ((version .&. versionMask) .|.+ (((fromIntegral $ fromEnum t) `shiftL`+ typeShiftAmount) .&. typeMask)) <>+ buildVarint (i32ToZigZag s) <>+ buildCompactValue (TString $ encodeUtf8 n)+ + readMessageBegin p = runParser p $ do+ pid <- fromIntegral <$> P.anyWord8+ when (pid /= protocolID) $ error "Bad Protocol ID"+ w <- fromIntegral <$> P.anyWord8+ let ver = w .&. versionMask + when (ver /= version) $ error "Bad Protocol version"+ let typ = (w `shiftR` typeShiftAmount) .&. typeBits+ seqId <- parseVarint zigZagToI32+ TString name <- parseCompactValue T_STRING+ return (decodeUtf8 name, toEnum $ fromIntegral $ typ, seqId)++ serializeVal _ = toLazyByteString . buildCompactValue+ deserializeVal _ ty bs =+ case LP.eitherResult $ LP.parse (parseCompactValue ty) bs of+ Left s -> error s+ Right val -> val++ readVal p ty = runParser p $ parseCompactValue ty+++-- | Writing Functions+buildCompactValue :: ThriftVal -> Builder+buildCompactValue (TStruct fields) = buildCompactStruct fields+buildCompactValue (TMap kt vt entries) =+ let len = fromIntegral $ length entries :: Word32 in+ if len == 0+ then B.word8 0x00+ else buildVarint len <>+ B.word8 (fromTType kt `shiftL` 4 .|. fromTType vt) <>+ buildCompactMap entries+buildCompactValue (TList ty entries) =+ let len = length entries in+ (if len < 15+ then B.word8 $ (fromIntegral len `shiftL` 4) .|. fromTType ty+ else B.word8 (0xF0 .|. fromTType ty) <>+ buildVarint (fromIntegral len :: Word32)) <>+ buildCompactList entries+buildCompactValue (TSet ty entries) = buildCompactValue (TList ty entries)+buildCompactValue (TBool b) =+ B.word8 $ toEnum $ if b then 1 else 0+buildCompactValue (TByte b) = int8 b+buildCompactValue (TI16 i) = buildVarint $ i16ToZigZag i+buildCompactValue (TI32 i) = buildVarint $ i32ToZigZag i+buildCompactValue (TI64 i) = buildVarint $ i64ToZigZag i+buildCompactValue (TDouble d) = doubleBE d+buildCompactValue (TString s) = buildVarint len <> lazyByteString s+ where+ len = fromIntegral (LBS.length s) :: Word32++buildCompactStruct :: Map.HashMap Int16 (LT.Text, ThriftVal) -> Builder+buildCompactStruct = flip (loop 0) mempty . Map.toList+ where+ loop _ [] acc = acc <> B.word8 (fromTType T_STOP)+ loop lastId ((fid, (_,val)) : fields) acc = loop fid fields $ acc <>+ (if fid > lastId && fid - lastId <= 15+ then B.word8 $ fromIntegral ((fid - lastId) `shiftL` 4) .|. typeOf val+ else B.word8 (typeOf val) <> buildVarint (i16ToZigZag fid)) <>+ (if typeOf val > 0x02 -- Not a T_BOOL+ then buildCompactValue val+ else mempty) -- T_BOOLs are encoded in the type+buildCompactMap :: [(ThriftVal, ThriftVal)] -> Builder+buildCompactMap = foldl combine mempty+ where+ combine s (key, val) = buildCompactValue key <> buildCompactValue val <> s++buildCompactList :: [ThriftVal] -> Builder+buildCompactList = foldr (mappend . buildCompactValue) mempty++-- | Reading Functions+parseCompactValue :: ThriftType -> Parser ThriftVal+parseCompactValue (T_STRUCT _) = TStruct <$> parseCompactStruct+parseCompactValue (T_MAP kt' vt') = do+ n <- parseVarint id+ if n == 0+ then return $ TMap kt' vt' []+ else do+ w <- P.anyWord8+ let kt = typeFrom $ w `shiftR` 4+ vt = typeFrom $ w .&. 0x0F+ TMap kt vt <$> parseCompactMap kt vt n+parseCompactValue (T_LIST ty) = TList ty <$> parseCompactList+parseCompactValue (T_SET ty) = TSet ty <$> parseCompactList+parseCompactValue T_BOOL = TBool . (/=0) <$> P.anyWord8+parseCompactValue T_BYTE = TByte . fromIntegral <$> P.anyWord8+parseCompactValue T_I16 = TI16 <$> parseVarint zigZagToI16+parseCompactValue T_I32 = TI32 <$> parseVarint zigZagToI32+parseCompactValue T_I64 = TI64 <$> parseVarint zigZagToI64+parseCompactValue T_DOUBLE = TDouble . bsToDouble <$> P.take 8+parseCompactValue T_STRING = do+ len :: Word32 <- parseVarint id+ TString . LBS.fromStrict <$> P.take (fromIntegral len)+parseCompactValue ty = error $ "Cannot read value of type " ++ show ty++parseCompactStruct :: Parser (Map.HashMap Int16 (LT.Text, ThriftVal))+parseCompactStruct = Map.fromList <$> parseFields 0+ where+ parseFields :: Int16 -> Parser [(Int16, (LT.Text, ThriftVal))]+ parseFields lastId = do+ w <- P.anyWord8+ if w == 0x00+ then return []+ else do+ let ty = typeFrom (w .&. 0x0F)+ modifier = (w .&. 0xF0) `shiftR` 4+ fid <- if modifier /= 0+ then return (lastId + fromIntegral modifier)+ else parseVarint zigZagToI16+ val <- if ty == T_BOOL+ then return (TBool $ (w .&. 0x0F) == 0x01)+ else parseCompactValue ty+ ((fid, (LT.empty, val)) : ) <$> parseFields fid++parseCompactMap :: ThriftType -> ThriftType -> Int32 ->+ Parser [(ThriftVal, ThriftVal)]+parseCompactMap kt vt n | n <= 0 = return []+ | otherwise = do+ k <- parseCompactValue kt+ v <- parseCompactValue vt+ ((k,v) :) <$> parseCompactMap kt vt (n-1)++parseCompactList :: Parser [ThriftVal]+parseCompactList = do+ w <- P.anyWord8+ let ty = typeFrom $ w .&. 0x0F+ lsize = w `shiftR` 4+ size <- if lsize == 0xF+ then parseVarint id+ else return $ fromIntegral lsize+ loop ty size+ where+ loop :: ThriftType -> Int32 -> Parser [ThriftVal]+ loop ty n | n <= 0 = return []+ | otherwise = liftM2 (:) (parseCompactValue ty)+ (loop ty (n-1))++-- Signed numbers must be converted to "Zig Zag" format before they can be+-- serialized in the Varint format+i16ToZigZag :: Int16 -> Word16+i16ToZigZag n = fromIntegral $ (n `shiftL` 1) `xor` (n `shiftR` 15)++zigZagToI16 :: Word16 -> Int16+zigZagToI16 n = fromIntegral $ (n `shiftR` 1) `xor` negate (n .&. 0x1)++i32ToZigZag :: Int32 -> Word32+i32ToZigZag n = fromIntegral $ (n `shiftL` 1) `xor` (n `shiftR` 31)++zigZagToI32 :: Word32 -> Int32+zigZagToI32 n = fromIntegral $ (n `shiftR` 1) `xor` negate (n .&. 0x1)++i64ToZigZag :: Int64 -> Word64+i64ToZigZag n = fromIntegral $ (n `shiftL` 1) `xor` (n `shiftR` 63)++zigZagToI64 :: Word64 -> Int64+zigZagToI64 n = fromIntegral $ (n `shiftR` 1) `xor` negate (n .&. 0x1)++buildVarint :: (Bits a, Integral a) => a -> Builder+buildVarint n | n .&. complement 0x7F == 0 = B.word8 $ fromIntegral n+ | otherwise = B.word8 (0x80 .|. (fromIntegral n .&. 0x7F)) <>+ buildVarint (n `shiftR` 7)++parseVarint :: (Bits a, Integral a, Ord a) => (a -> b) -> Parser b+parseVarint fromZigZag = do+ bytestemp <- BS.unpack <$> P.takeTill (not . flip testBit 7)+ lsb <- P.anyWord8+ let bytes = lsb : List.reverse bytestemp+ return $ fromZigZag $ List.foldl' combine 0x00 bytes+ where combine a b = (a `shiftL` 7) .|. (fromIntegral b .&. 0x7f)++-- | Compute the Compact Type+fromTType :: ThriftType -> Word8+fromTType ty = case ty of+ T_STOP -> 0x00+ T_BOOL -> 0x01+ T_BYTE -> 0x03+ T_I16 -> 0x04+ T_I32 -> 0x05+ T_I64 -> 0x06+ T_DOUBLE -> 0x07+ T_STRING -> 0x08+ T_LIST{} -> 0x09+ T_SET{} -> 0x0A+ T_MAP{} -> 0x0B+ T_STRUCT{} -> 0x0C+ T_VOID -> error "No Compact type for T_VOID"++typeOf :: ThriftVal -> Word8+typeOf v = case v of+ TBool True -> 0x01+ TBool False -> 0x02+ TByte _ -> 0x03+ TI16 _ -> 0x04+ TI32 _ -> 0x05+ TI64 _ -> 0x06+ TDouble _ -> 0x07+ TString _ -> 0x08+ TList{} -> 0x09+ TSet{} -> 0x0A+ TMap{} -> 0x0B+ TStruct{} -> 0x0C+ +typeFrom :: Word8 -> ThriftType+typeFrom w = case w of+ 0x01 -> T_BOOL+ 0x02 -> T_BOOL+ 0x03 -> T_BYTE+ 0x04 -> T_I16+ 0x05 -> T_I32+ 0x06 -> T_I64+ 0x07 -> T_DOUBLE+ 0x08 -> T_STRING+ 0x09 -> T_LIST T_VOID+ 0x0A -> T_SET T_VOID+ 0x0B -> T_MAP T_VOID T_VOID+ 0x0C -> T_STRUCT Map.empty+ n -> error $ "typeFrom: " ++ show n ++ " is not a compact type"
+ src/Thrift/Protocol/JSON.hs view
@@ -0,0 +1,325 @@+--+-- Licensed to the Apache Software Foundation (ASF) under one+-- or more contributor license agreements. See the NOTICE file+-- distributed with this work for additional information+-- regarding copyright ownership. The ASF licenses this file+-- to you under the Apache License, Version 2.0 (the+-- "License"); you may not use this file except in compliance+-- with the License. You may obtain a copy of the License at+--+-- http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing,+-- software distributed under the License is distributed on an+-- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY+-- KIND, either express or implied. See the License for the+-- specific language governing permissions and limitations+-- under the License.+--++{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module Thrift.Protocol.JSON+ ( module Thrift.Protocol+ , JSONProtocol(..)+ ) where++import Control.Applicative+import Control.Monad+import Data.Attoparsec.ByteString as P+import Data.Attoparsec.ByteString.Char8 as PC+import Data.Attoparsec.ByteString.Lazy as LP+import Data.ByteString.Lazy.Builder as B+import Data.ByteString.Internal (c2w, w2c)+import Data.Functor+import Data.Int+import Data.List+import Data.Maybe (catMaybes)+import Data.Monoid+import Data.Text.Lazy.Encoding+import Data.Word+import qualified Data.HashMap.Strict as Map++import Thrift.Protocol+import Thrift.Transport+import Thrift.Types++import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text.Lazy as LT++-- | The JSON Protocol data uses the standard 'TSimpleJSONProtocol'. Data is+-- encoded as a JSON 'ByteString'+data JSONProtocol t = JSONProtocol t+ -- ^ Construct a 'JSONProtocol' with a 'Transport'++instance Protocol JSONProtocol where+ getTransport (JSONProtocol t) = t++ writeMessageBegin (JSONProtocol t) (s, ty, sq) = tWrite t $ toLazyByteString $+ B.char8 '[' <> buildShowable (1 :: Int32) <>+ B.string8 ",\"" <> escape (encodeUtf8 s) <> B.char8 '\"' <>+ B.char8 ',' <> buildShowable (fromEnum ty) <>+ B.char8 ',' <> buildShowable sq <>+ B.char8 ','+ writeMessageEnd (JSONProtocol t) = tWrite t "]"+ readMessageBegin p = runParser p $ skipSpace *> do+ _ver :: Int32 <- lexeme (PC.char8 '[') *> lexeme (signed decimal)+ bs <- lexeme (PC.char8 ',') *> lexeme escapedString+ case decodeUtf8' bs of+ Left _ -> fail "readMessage: invalid text encoding"+ Right str -> do+ ty <- toEnum <$> (lexeme (PC.char8 ',') *> lexeme (signed decimal))+ seqNum <- lexeme (PC.char8 ',') *> lexeme (signed decimal)+ _ <- PC.char8 ','+ return (str, ty, seqNum)+ readMessageEnd p = void $ runParser p (PC.char8 ']')++ serializeVal _ = toLazyByteString . buildJSONValue+ deserializeVal _ ty bs =+ case LP.eitherResult $ LP.parse (parseJSONValue ty) bs of+ Left s -> error s+ Right val -> val++ readVal p ty = runParser p $ skipSpace *> parseJSONValue ty+++-- Writing Functions++buildJSONValue :: ThriftVal -> Builder+buildJSONValue (TStruct fields) = B.char8 '{' <> buildJSONStruct fields <> B.char8 '}'+buildJSONValue (TMap kt vt entries) =+ B.char8 '[' <> B.char8 '"' <> getTypeName kt <> B.char8 '"' <>+ B.char8 ',' <> B.char8 '"' <> getTypeName vt <> B.char8 '"' <>+ B.char8 ',' <> buildShowable (length entries) <>+ B.char8 ',' <> B.char8 '{' <> buildJSONMap entries <> B.char8 '}' <>+ B.char8 ']'+buildJSONValue (TList ty entries) =+ B.char8 '[' <> B.char8 '"' <> getTypeName ty <> B.char8 '"' <>+ B.char8 ',' <> buildShowable (length entries) <>+ (if length entries > 0+ then B.char8 ',' <> buildJSONList entries+ else mempty) <>+ B.char8 ']'+buildJSONValue (TSet ty entries) = buildJSONValue (TList ty entries)+buildJSONValue (TBool b) = if b then B.string8 "true" else B.string8 "false"+buildJSONValue (TByte b) = buildShowable b+buildJSONValue (TI16 i) = buildShowable i+buildJSONValue (TI32 i) = buildShowable i+buildJSONValue (TI64 i) = buildShowable i+buildJSONValue (TDouble d) = buildShowable d+buildJSONValue (TString s) = B.char8 '\"' <> escape s <> B.char8 '\"'++buildJSONStruct :: Map.HashMap Int16 (LT.Text, ThriftVal) -> Builder+buildJSONStruct = mconcat . intersperse (B.char8 ',') . Map.foldrWithKey buildField []+ where + buildField fid (_,val) = (:) $+ B.char8 '"' <> buildShowable fid <> B.string8 "\":" <> + B.char8 '{' <>+ B.char8 '"' <> getTypeName (getTypeOf val) <> B.string8 "\":" <>+ buildJSONValue val <>+ B.char8 '}'++buildJSONMap :: [(ThriftVal, ThriftVal)] -> Builder+buildJSONMap = mconcat . intersperse (B.char8 ',') . map buildKV+ where+ buildKV (key@(TString _), val) =+ buildJSONValue key <> B.char8 ':' <> buildJSONValue val+ buildKV (key, val) =+ B.char8 '\"' <> buildJSONValue key <> B.string8 "\":" <> buildJSONValue val+buildJSONList :: [ThriftVal] -> Builder+buildJSONList = mconcat . intersperse (B.char8 ',') . map buildJSONValue++buildShowable :: Show a => a -> Builder+buildShowable = B.string8 . show++-- Reading Functions++parseJSONValue :: ThriftType -> Parser ThriftVal+parseJSONValue (T_STRUCT tmap) =+ TStruct <$> (lexeme (PC.char8 '{') *> parseJSONStruct tmap <* PC.char8 '}')+parseJSONValue (T_MAP kt vt) = fmap (TMap kt vt) $+ between '[' ']' $+ lexeme escapedString *> lexeme (PC.char8 ',') *>+ lexeme escapedString *> lexeme (PC.char8 ',') *>+ lexeme decimal *> lexeme (PC.char8 ',') *>+ between '{' '}' (parseJSONMap kt vt)+parseJSONValue (T_LIST ty) = fmap (TList ty) $+ between '[' ']' $ do+ len <- lexeme escapedString *> lexeme (PC.char8 ',') *>+ lexeme decimal <* lexeme (PC.char8 ',')+ if len > 0 then parseJSONList ty else return []+parseJSONValue (T_SET ty) = fmap (TSet ty) $+ between '[' ']' $ do+ len <- lexeme escapedString *> lexeme (PC.char8 ',') *>+ lexeme decimal <* lexeme (PC.char8 ',')+ if len > 0 then parseJSONList ty else return []+parseJSONValue T_BOOL =+ (TBool True <$ string "true") <|> (TBool False <$ string "false")+parseJSONValue T_BYTE = TByte <$> signed decimal+parseJSONValue T_I16 = TI16 <$> signed decimal+parseJSONValue T_I32 = TI32 <$> signed decimal+parseJSONValue T_I64 = TI64 <$> signed decimal+parseJSONValue T_DOUBLE = TDouble <$> double+parseJSONValue T_STRING = TString <$> escapedString+parseJSONValue T_STOP = fail "parseJSONValue: cannot parse type T_STOP"+parseJSONValue T_VOID = fail "parseJSONValue: cannot parse type T_VOID"++parseAnyValue :: Parser ()+parseAnyValue = choice $+ skipBetween '{' '}' :+ skipBetween '[' ']' :+ map (void . parseJSONValue)+ [ T_BOOL+ , T_I16+ , T_I32+ , T_I64+ , T_DOUBLE+ , T_STRING+ ]+ where+ skipBetween :: Char -> Char -> Parser ()+ skipBetween a b = between a b $ void (PC.satisfy (\c -> c /= a && c /= b))+ <|> skipBetween a b++parseJSONStruct :: TypeMap -> Parser (Map.HashMap Int16 (LT.Text, ThriftVal))+parseJSONStruct tmap = Map.fromList . catMaybes <$> parseField+ `sepBy` lexeme (PC.char8 ',')+ where+ parseField = do+ fid <- lexeme (between '"' '"' decimal) <* lexeme (PC.char8 ':')+ case Map.lookup fid tmap of+ Just (str, ftype) -> between '{' '}' $ do+ _ <- lexeme (escapedString) *> lexeme (PC.char8 ':')+ val <- lexeme (parseJSONValue ftype)+ return $ Just (fid, (str, val))+ Nothing -> lexeme parseAnyValue *> return Nothing++parseJSONMap :: ThriftType -> ThriftType -> Parser [(ThriftVal, ThriftVal)]+parseJSONMap kt vt =+ ((,) <$> lexeme (PC.char8 '"' *> parseJSONValue kt <* PC.char8 '"') <*>+ (lexeme (PC.char8 ':') *> lexeme (parseJSONValue vt))) `sepBy`+ lexeme (PC.char8 ',')++parseJSONList :: ThriftType -> Parser [ThriftVal]+parseJSONList ty = lexeme (parseJSONValue ty) `sepBy` lexeme (PC.char8 ',')++escapedString :: Parser LBS.ByteString+escapedString = PC.char8 '"' *>+ (LBS.pack <$> P.many' (escapedChar <|> notChar8 '"')) <*+ PC.char8 '"'++escapedChar :: Parser Word8+escapedChar = PC.char8 '\\' *> (c2w <$> choice+ [ '\SOH' <$ P.string "u0001"+ , '\STX' <$ P.string "u0002"+ , '\ETX' <$ P.string "u0003"+ , '\EOT' <$ P.string "u0004"+ , '\ENQ' <$ P.string "u0005"+ , '\ACK' <$ P.string "u0006"+ , '\BEL' <$ P.string "u0007"+ , '\BS' <$ P.string "u0008"+ , '\VT' <$ P.string "u000b"+ , '\FF' <$ P.string "u000c"+ , '\CR' <$ P.string "u000d"+ , '\SO' <$ P.string "u000e"+ , '\SI' <$ P.string "u000f"+ , '\DLE' <$ P.string "u0010"+ , '\DC1' <$ P.string "u0011"+ , '\DC2' <$ P.string "u0012"+ , '\DC3' <$ P.string "u0013"+ , '\DC4' <$ P.string "u0014"+ , '\NAK' <$ P.string "u0015"+ , '\SYN' <$ P.string "u0016"+ , '\ETB' <$ P.string "u0017"+ , '\CAN' <$ P.string "u0018"+ , '\EM' <$ P.string "u0019"+ , '\SUB' <$ P.string "u001a"+ , '\ESC' <$ P.string "u001b"+ , '\FS' <$ P.string "u001c"+ , '\GS' <$ P.string "u001d"+ , '\RS' <$ P.string "u001e"+ , '\US' <$ P.string "u001f"+ , '\DEL' <$ P.string "u007f"+ , '\0' <$ PC.char '0'+ , '\a' <$ PC.char 'a'+ , '\b' <$ PC.char 'b'+ , '\f' <$ PC.char 'f'+ , '\n' <$ PC.char 'n'+ , '\r' <$ PC.char 'r'+ , '\t' <$ PC.char 't'+ , '\v' <$ PC.char 'v'+ , '\"' <$ PC.char '"'+ , '\'' <$ PC.char '\''+ , '\\' <$ PC.char '\\'+ , '/' <$ PC.char '/'+ ])++escape :: LBS.ByteString -> Builder+escape = LBS.foldl' escapeChar mempty+ where+ escapeChar b w = b <> (B.lazyByteString $ case w2c w of+ '\0' -> "\\0"+ '\b' -> "\\b"+ '\f' -> "\\f"+ '\n' -> "\\n"+ '\r' -> "\\r"+ '\t' -> "\\t"+ '\"' -> "\\\""+ '\\' -> "\\\\"+ '\SOH' -> "\\u0001"+ '\STX' -> "\\u0002"+ '\ETX' -> "\\u0003"+ '\EOT' -> "\\u0004"+ '\ENQ' -> "\\u0005"+ '\ACK' -> "\\u0006"+ '\BEL' -> "\\u0007"+ '\VT' -> "\\u000b"+ '\SO' -> "\\u000e"+ '\SI' -> "\\u000f"+ '\DLE' -> "\\u0010"+ '\DC1' -> "\\u0011"+ '\DC2' -> "\\u0012"+ '\DC3' -> "\\u0013"+ '\DC4' -> "\\u0014"+ '\NAK' -> "\\u0015"+ '\SYN' -> "\\u0016"+ '\ETB' -> "\\u0017"+ '\CAN' -> "\\u0018"+ '\EM' -> "\\u0019"+ '\SUB' -> "\\u001a"+ '\ESC' -> "\\u001b"+ '\FS' -> "\\u001c"+ '\GS' -> "\\u001d"+ '\RS' -> "\\u001e"+ '\US' -> "\\u001f"+ '\DEL' -> "\\u007f"+ _ -> LBS.singleton w)++lexeme :: Parser a -> Parser a+lexeme = (<* skipSpace)++notChar8 :: Char -> Parser Word8+notChar8 c = P.satisfy (/= c2w c)++between :: Char -> Char -> Parser a -> Parser a+between a b p = lexeme (PC.char8 a) *> lexeme p <* lexeme (PC.char8 b)++getTypeName :: ThriftType -> Builder+getTypeName ty = B.string8 $ case ty of+ T_STRUCT _ -> "rec"+ T_MAP _ _ -> "map"+ T_LIST _ -> "lst"+ T_SET _ -> "set"+ T_BOOL -> "tf"+ T_BYTE -> "i8"+ T_I16 -> "i16"+ T_I32 -> "i32"+ T_I64 -> "i64"+ T_DOUBLE -> "dbl"+ T_STRING -> "str"+ _ -> error "Unrecognized Type"+
src/Thrift/Transport.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-} -- -- Licensed to the Apache Software Foundation (ASF) under one -- or more contributor license agreements. See the NOTICE file@@ -26,8 +27,9 @@ import Control.Monad ( when ) import Control.Exception ( Exception, throw )-+import Data.Functor ( (<$>) ) import Data.Typeable ( Typeable )+import Data.Word import qualified Data.ByteString.Lazy as LBS import Data.Monoid@@ -36,6 +38,7 @@ tIsOpen :: a -> IO Bool tClose :: a -> IO () tRead :: a -> Int -> IO LBS.ByteString+ tPeek :: a -> IO (Maybe Word8) tWrite :: a -> LBS.ByteString -> IO () tFlush :: a -> IO () tReadAll :: a -> Int -> IO LBS.ByteString@@ -46,8 +49,8 @@ let rlen = fromIntegral $ LBS.length result when (rlen == 0) (throw $ TransportExn "Cannot read. Remote side has closed." TE_UNKNOWN) if len <= rlen- then return result- else (result `mappend`) `fmap` (tReadAll a (len - rlen))+ then return result+ else (result `mappend`) <$> tReadAll a (len - rlen) data TransportExn = TransportExn String TransportExnType deriving ( Show, Typeable )@@ -60,4 +63,3 @@ | TE_TIMED_OUT | TE_END_OF_FILE deriving ( Eq, Show, Typeable )-
+ src/Thrift/Transport/Empty.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+--+-- Licensed to the Apache Software Foundation (ASF) under one+-- or more contributor license agreements. See the NOTICE file+-- distributed with this work for additional information+-- regarding copyright ownership. The ASF licenses this file+-- to you under the Apache License, Version 2.0 (the+-- "License"); you may not use this file except in compliance+-- with the License. You may obtain a copy of the License at+--+-- http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing,+-- software distributed under the License is distributed on an+-- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY+-- KIND, either express or implied. See the License for the+-- specific language governing permissions and limitations+-- under the License.+--++module Thrift.Transport.Empty+ ( EmptyTransport(..)+ ) where++import Thrift.Transport++data EmptyTransport = EmptyTransport++instance Transport EmptyTransport where+ tIsOpen = const $ return False+ tClose = const $ return ()+ tRead _ _ = return ""+ tPeek = const $ return Nothing+ tWrite _ _ = return ()+ tFlush = const$ return ()
+ src/Thrift/Transport/Framed.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+--+-- Licensed to the Apache Software Foundation (ASF) under one+-- or more contributor license agreements. See the NOTICE file+-- distributed with this work for additional information+-- regarding copyright ownership. The ASF licenses this file+-- to you under the Apache License, Version 2.0 (the+-- "License"); you may not use this file except in compliance+-- with the License. You may obtain a copy of the License at+--+-- http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing,+-- software distributed under the License is distributed on an+-- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY+-- KIND, either express or implied. See the License for the+-- specific language governing permissions and limitations+-- under the License.+--++module Thrift.Transport.Framed+ ( module Thrift.Transport+ , FramedTransport+ , openFramedTransport+ ) where++import Thrift.Transport+import Thrift.Transport.IOBuffer++import Data.Int (Int32)+import qualified Data.Binary as B+import qualified Data.ByteString.Lazy as LBS+++-- | FramedTransport wraps a given transport in framed mode.+data FramedTransport t = FramedTransport {+ wrappedTrans :: t, -- ^ Underlying transport.+ writeBuffer :: WriteBuffer, -- ^ Write buffer.+ readBuffer :: ReadBuffer -- ^ Read buffer.+ }++-- | Create a new framed transport which wraps the given transport.+openFramedTransport :: Transport t => t -> IO (FramedTransport t)+openFramedTransport trans = do+ wbuf <- newWriteBuffer+ rbuf <- newReadBuffer+ return FramedTransport{ wrappedTrans = trans, writeBuffer = wbuf, readBuffer = rbuf }++instance Transport t => Transport (FramedTransport t) where++ tClose = tClose . wrappedTrans++ tRead trans n = do+ -- First, check the read buffer for any data.+ bs <- readBuf (readBuffer trans) n+ if LBS.null bs+ then+ -- When the buffer is empty, read another frame from the+ -- underlying transport.+ do len <- readFrame trans+ if len > 0+ then tRead trans n+ else return bs+ else return bs+ tPeek trans = do+ mw <- peekBuf (readBuffer trans)+ case mw of+ Just _ -> return mw+ Nothing -> do+ len <- readFrame trans+ if len > 0+ then tPeek trans+ else return Nothing++ tWrite = writeBuf . writeBuffer++ tFlush trans = do+ bs <- flushBuf (writeBuffer trans)+ let szBs = B.encode $ (fromIntegral $ LBS.length bs :: Int32)+ tWrite (wrappedTrans trans) szBs+ tWrite (wrappedTrans trans) bs+ tFlush (wrappedTrans trans)++ tIsOpen = tIsOpen . wrappedTrans++readFrame :: Transport t => FramedTransport t -> IO Int+readFrame trans = do+ -- Read and decode the frame size.+ szBs <- tRead (wrappedTrans trans) 4+ let sz = fromIntegral (B.decode szBs :: Int32)++ -- Read the frame and stuff it into the read buffer.+ bs <- tRead (wrappedTrans trans) sz+ fillBuf (readBuffer trans) bs++ -- Return the frame size so that the caller knows whether to expect+ -- something in the read buffer or not.+ return sz
src/Thrift/Transport/Handle.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -27,8 +27,9 @@ , HandleSource(..) ) where -import Control.Exception ( throw )-import Control.Monad ()+import Control.Exception ( catch, throw )+import Data.ByteString.Internal (c2w)+import Data.Functor import Network @@ -42,9 +43,10 @@ instance Transport Handle where tIsOpen = hIsOpen- tClose h = hClose h- tRead h n = LBS.hGet h n `catch` handleEOF- tWrite h s = LBS.hPut h s+ tClose = hClose+ tRead h n = LBS.hGet h n `Control.Exception.catch` handleEOF mempty+ tPeek h = (Just . c2w <$> hLookAhead h) `Control.Exception.catch` handleEOF Nothing+ tWrite = LBS.hPut tFlush = hFlush @@ -60,7 +62,7 @@ hOpen = uncurry connectTo -handleEOF :: forall a (m :: * -> *).(Monoid a, Monad m) => IOError -> m a-handleEOF e = if isEOFError e- then return mempty+handleEOF :: a -> IOError -> IO a+handleEOF a e = if isEOFError e+ then return a else throw $ TransportExn "TChannelTransport: Could not read" TE_UNKNOWN
src/Thrift/Transport/HttpClient.hs view
@@ -22,18 +22,16 @@ ( module Thrift.Transport , HttpClient (..) , openHttpClient- ) where+) where import Thrift.Transport+import Thrift.Transport.IOBuffer import Network.URI import Network.HTTP hiding (port, host) -import Control.Monad (liftM) import Data.Maybe (fromJust)-import Data.Monoid (mappend, mempty)+import Data.Monoid (mempty) import Control.Exception (throw)-import Control.Concurrent.MVar-import qualified Data.Binary.Builder as B import qualified Data.ByteString.Lazy as LBS @@ -73,12 +71,14 @@ instance Transport HttpClient where - tClose = close . hstream+ tClose = close . hstream - tRead hclient n = readBuf (readBuffer hclient) n+ tPeek = peekBuf . readBuffer - tWrite hclient = writeBuf (writeBuffer hclient)+ tRead = readBuf . readBuffer + tWrite = writeBuf . writeBuffer+ tFlush hclient = do body <- flushBuf $ writeBuffer hclient let request = Request {@@ -92,36 +92,10 @@ res <- sendHTTP (hstream hclient) request case res of- Right response -> do- fillBuf (readBuffer hclient) (rspBody response)- Left _ -> do+ Right response ->+ fillBuf (readBuffer hclient) (rspBody response)+ Left _ -> throw $ TransportExn "THttpConnection: HTTP failure from server" TE_UNKNOWN return () tIsOpen _ = return True--- Mini IO buffers--type WriteBuffer = MVar (B.Builder)--newWriteBuffer :: IO WriteBuffer-newWriteBuffer = newMVar mempty--writeBuf :: WriteBuffer -> LBS.ByteString -> IO ()-writeBuf w s = modifyMVar_ w $ return . (\builder ->- builder `mappend` (B.fromLazyByteString s))--flushBuf :: WriteBuffer -> IO (LBS.ByteString)-flushBuf w = B.toLazyByteString `liftM` swapMVar w mempty---type ReadBuffer = MVar (LBS.ByteString)--newReadBuffer :: IO ReadBuffer-newReadBuffer = newMVar mempty--fillBuf :: ReadBuffer -> LBS.ByteString -> IO ()-fillBuf r s = swapMVar r s >> return ()--readBuf :: ReadBuffer -> Int -> IO (LBS.ByteString)-readBuf r n = modifyMVar r $ return . flipPair . LBS.splitAt (fromIntegral n)- where flipPair (a, b) = (b, a)
+ src/Thrift/Transport/IOBuffer.hs view
@@ -0,0 +1,69 @@+--+-- Licensed to the Apache Software Foundation (ASF) under one+-- or more contributor license agreements. See the NOTICE file+-- distributed with this work for additional information+-- regarding copyright ownership. The ASF licenses this file+-- to you under the Apache License, Version 2.0 (the+-- "License"); you may not use this file except in compliance+-- with the License. You may obtain a copy of the License at+--+-- http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing,+-- software distributed under the License is distributed on an+-- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY+-- KIND, either express or implied. See the License for the+-- specific language governing permissions and limitations+-- under the License.+--++module Thrift.Transport.IOBuffer+ ( WriteBuffer+ , newWriteBuffer+ , writeBuf+ , flushBuf+ , ReadBuffer+ , newReadBuffer+ , fillBuf+ , readBuf+ , peekBuf+ ) where++import Data.ByteString.Lazy.Builder+import Data.Functor+import Data.IORef+import Data.Monoid+import Data.Word++import qualified Data.ByteString.Lazy as LBS++type WriteBuffer = IORef Builder+type ReadBuffer = IORef LBS.ByteString++newWriteBuffer :: IO WriteBuffer+newWriteBuffer = newIORef mempty++writeBuf :: WriteBuffer -> LBS.ByteString -> IO ()+writeBuf w s = modifyIORef w ( <> lazyByteString s)++flushBuf :: WriteBuffer -> IO LBS.ByteString+flushBuf w = do+ buf <- readIORef w+ writeIORef w mempty+ return $ toLazyByteString buf++newReadBuffer :: IO ReadBuffer+newReadBuffer = newIORef mempty++fillBuf :: ReadBuffer -> LBS.ByteString -> IO ()+fillBuf = writeIORef++readBuf :: ReadBuffer -> Int -> IO LBS.ByteString+readBuf r n = do+ bs <- readIORef r+ let (hd, tl) = LBS.splitAt (fromIntegral n) bs+ writeIORef r tl+ return hd++peekBuf :: ReadBuffer -> IO (Maybe Word8)+peekBuf r = (fmap fst . LBS.uncons) <$> readIORef r
+ src/Thrift/Types.hs view
@@ -0,0 +1,132 @@+-- Licensed to the Apache Software Foundation (ASF) under one+-- or more contributor license agreements. See the NOTICE file+-- distributed with this work for additional information+-- regarding copyright ownership. The ASF licenses this file+-- to you under the Apache License, Version 2.0 (the+-- "License"); you may not use this file except in compliance+-- with the License. You may obtain a copy of the License at+--+-- http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing,+-- software distributed under the License is distributed on an+-- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY+-- KIND, either express or implied. See the License for the+-- specific language governing permissions and limitations+-- under the License.+--++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Thrift.Types where++import Data.Foldable (foldl')+import Data.Hashable ( Hashable, hashWithSalt )+import Data.Int+import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Gen (elements)+import Data.Text.Lazy (Text)+import qualified Data.ByteString.Lazy as LBS+import qualified Data.HashMap.Strict as Map+import qualified Data.HashSet as Set+import qualified Data.Vector as Vector++instance (Hashable k, Hashable v) => Hashable (Map.HashMap k v) where+ hashWithSalt salt = foldl' hashWithSalt salt . Map.toList++instance (Hashable a) => Hashable (Set.HashSet a) where+ hashWithSalt = foldl' hashWithSalt++instance (Hashable a) => Hashable (Vector.Vector a) where+ hashWithSalt = Vector.foldl' hashWithSalt+++type TypeMap = Map.HashMap Int16 (Text, ThriftType)++data ThriftVal = TStruct (Map.HashMap Int16 (Text, ThriftVal))+ | TMap ThriftType ThriftType [(ThriftVal, ThriftVal)]+ | TList ThriftType [ThriftVal]+ | TSet ThriftType [ThriftVal]+ | TBool Bool+ | TByte Int8+ | TI16 Int16+ | TI32 Int32+ | TI64 Int64+ | TString LBS.ByteString+ | TDouble Double+ deriving (Eq, Show)++-- Information is needed here for collection types (ie T_STRUCT, T_MAP,+-- T_LIST, and T_SET) so that we know what types those collections are+-- parameterized by. In most protocols, this cannot be discerned directly+-- from the data being read.+data ThriftType+ = T_STOP+ | T_VOID+ | T_BOOL+ | T_BYTE+ | T_DOUBLE+ | T_I16+ | T_I32+ | T_I64+ | T_STRING+ | T_STRUCT TypeMap+ | T_MAP ThriftType ThriftType+ | T_SET ThriftType+ | T_LIST ThriftType+ deriving ( Eq, Show )++-- NOTE: when using toEnum information about parametized types is NOT preserved.+-- This design choice is consistent woth the Thrift implementation in other+-- languages+instance Enum ThriftType where+ fromEnum T_STOP = 0+ fromEnum T_VOID = 1+ fromEnum T_BOOL = 2+ fromEnum T_BYTE = 3+ fromEnum T_DOUBLE = 4+ fromEnum T_I16 = 6+ fromEnum T_I32 = 8+ fromEnum T_I64 = 10+ fromEnum T_STRING = 11+ fromEnum (T_STRUCT _) = 12+ fromEnum (T_MAP _ _) = 13+ fromEnum (T_SET _) = 14+ fromEnum (T_LIST _) = 15++ toEnum 0 = T_STOP+ toEnum 1 = T_VOID+ toEnum 2 = T_BOOL+ toEnum 3 = T_BYTE+ toEnum 4 = T_DOUBLE+ toEnum 6 = T_I16+ toEnum 8 = T_I32+ toEnum 10 = T_I64+ toEnum 11 = T_STRING+ toEnum 12 = T_STRUCT Map.empty+ toEnum 13 = T_MAP T_VOID T_VOID+ toEnum 14 = T_SET T_VOID+ toEnum 15 = T_LIST T_VOID+ toEnum t = error $ "Invalid ThriftType " ++ show t++data MessageType+ = M_CALL+ | M_REPLY+ | M_EXCEPTION+ | M_ONEWAY+ deriving ( Eq, Show )++instance Enum MessageType where+ fromEnum M_CALL = 1+ fromEnum M_REPLY = 2+ fromEnum M_EXCEPTION = 3+ fromEnum M_ONEWAY = 4++ toEnum 1 = M_CALL+ toEnum 2 = M_REPLY+ toEnum 3 = M_EXCEPTION+ toEnum 4 = M_ONEWAY+ toEnum t = error $ "Invalid MessageType " ++ show t++instance Arbitrary MessageType where+ arbitrary = elements [M_CALL, M_REPLY, M_EXCEPTION, M_ONEWAY]
thrift.cabal view
@@ -18,8 +18,8 @@ -- Name: thrift-Version: 0.6.0-Cabal-Version: >= 1.4+Version: 0.9.2+Cabal-Version: >= 1.8 License: OtherLicense Category: Foreign Build-Type: Simple@@ -27,21 +27,46 @@ Homepage: http://thrift.apache.org Bug-Reports: https://issues.apache.org/jira/browse/THRIFT Maintainer: dev@thrift.apache.org-License-File: LICENSE+License-File: ../../LICENSE Description: Haskell bindings for the Apache Thrift RPC system. Requires the use of the thrift code generator. +flag network-uri+ description: Get Network.URI from the network-uri package+ default: True+ Library Hs-Source-Dirs: src Build-Depends:- base >= 4, base < 5, network, ghc-prim, binary, bytestring, HTTP+ base >= 4, base < 5, containers, ghc-prim, attoparsec, binary, bytestring >= 0.10, hashable, HTTP, text, unordered-containers, vector, QuickCheck, split+ if flag(network-uri)+ build-depends: network-uri >= 2.6, network >= 2.6+ else+ build-depends: network < 2.6 Exposed-Modules:- Thrift, Thrift.Protocol, Thrift.Transport, Thrift.Protocol.Binary- Thrift.Transport.Handle, Thrift.Transport.HttpClient, Thrift.Server+ Thrift,+ Thrift.Arbitraries+ Thrift.Protocol,+ Thrift.Protocol.Binary,+ Thrift.Protocol.Compact,+ Thrift.Protocol.JSON,+ Thrift.Server,+ Thrift.Transport,+ Thrift.Transport.Empty,+ Thrift.Transport.Framed,+ Thrift.Transport.Handle,+ Thrift.Transport.HttpClient,+ Thrift.Transport.IOBuffer,+ Thrift.Types Extensions:- DeriveDataTypeable, ExistentialQuantification, FlexibleInstances,- KindSignatures, MagicHash, RankNTypes,- ScopedTypeVariables, TypeSynonymInstances-+ DeriveDataTypeable,+ ExistentialQuantification,+ FlexibleInstances,+ KindSignatures,+ MagicHash,+ RankNTypes,+ RecordWildCards,+ ScopedTypeVariables,+ TypeSynonymInstances