diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + 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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,21 @@ +#!/usr/bin/env runhaskell + +> -- 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. + +> import Distribution.Simple +> main = defaultMain diff --git a/src/Thrift.hs b/src/Thrift.hs new file mode 100644 --- /dev/null +++ b/src/Thrift.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +-- +-- 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 + ( module Thrift.Transport + , module Thrift.Protocol + , AppExnType(..) + , AppExn(..) + , readAppExn + , writeAppExn + , ThriftException(..) + ) where + +import Control.Monad ( when ) +import Control.Exception + +import Data.Typeable ( Typeable ) + +import Thrift.Transport +import Thrift.Protocol + + +data ThriftException = ThriftException + deriving ( Show, Typeable ) +instance Exception ThriftException + +data AppExnType + = AE_UNKNOWN + | AE_UNKNOWN_METHOD + | AE_INVALID_MESSAGE_TYPE + | AE_WRONG_METHOD_NAME + | AE_BAD_SEQUENCE_ID + | AE_MISSING_RESULT + deriving ( Eq, Show, Typeable ) + +instance Enum AppExnType where + toEnum 0 = AE_UNKNOWN + toEnum 1 = AE_UNKNOWN_METHOD + toEnum 2 = AE_INVALID_MESSAGE_TYPE + toEnum 3 = AE_WRONG_METHOD_NAME + toEnum 4 = AE_BAD_SEQUENCE_ID + toEnum 5 = AE_MISSING_RESULT + toEnum t = error $ "Invalid AppExnType " ++ show t + + fromEnum AE_UNKNOWN = 0 + fromEnum AE_UNKNOWN_METHOD = 1 + fromEnum AE_INVALID_MESSAGE_TYPE = 2 + fromEnum AE_WRONG_METHOD_NAME = 3 + fromEnum AE_BAD_SEQUENCE_ID = 4 + fromEnum AE_MISSING_RESULT = 5 + +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 + +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 + diff --git a/src/Thrift/Protocol.hs b/src/Thrift/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Thrift/Protocol.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-- +-- 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.Protocol + ( Protocol(..) + , skip + , MessageType(..) + , ThriftType(..) + , ProtocolExn(..) + , ProtocolExnType(..) + ) where + +import Control.Monad ( replicateM_, unless ) +import Control.Exception +import Data.Int +import Data.Typeable ( Typeable ) +import Data.ByteString.Lazy + +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 + + +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 + + +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) + + +data ProtocolExnType + = PE_UNKNOWN + | PE_INVALID_DATA + | PE_NEGATIVE_SIZE + | PE_SIZE_LIMIT + | PE_BAD_VERSION + deriving ( Eq, Show, Typeable ) + +data ProtocolExn = ProtocolExn ProtocolExnType String + deriving ( Show, Typeable ) +instance Exception ProtocolExn diff --git a/src/Thrift/Protocol/Binary.hs b/src/Thrift/Protocol/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Thrift/Protocol/Binary.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE MagicHash #-} +-- +-- 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.Protocol.Binary + ( module Thrift.Protocol + , BinaryProtocol(..) + ) where + +import Control.Exception ( throw ) +import Control.Monad ( liftM ) + +import qualified Data.Binary +import Data.Bits +import Data.Int + +import GHC.Exts +import GHC.Word + +import Thrift.Protocol +import Thrift.Transport + +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 + + +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 () + + 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 () + + 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 + + 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 () + + readBool p = (== 1) `fmap` readByte p + + readByte p = do + bs <- tReadAll (getTransport p) 1 + return $ Data.Binary.decode bs + + readI16 p = do + bs <- tReadAll (getTransport p) 2 + return $ Data.Binary.decode bs + + readI32 p = do + bs <- tReadAll (getTransport p) 4 + return $ Data.Binary.decode bs + + readI64 p = do + bs <- tReadAll (getTransport p) 8 + return $ Data.Binary.decode bs + + readDouble p = do + bs <- readI64 p + return $ floatOfBits $ fromIntegral bs + + readString p = do + i <- readI32 p + LBSChar8.unpack `liftM` tReadAll (getTransport p) (fromIntegral i) + + readBinary p = do + i <- readI32 p + tReadAll (getTransport p) (fromIntegral i) + + +-- | 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 + +floatBits :: Double -> Word64 +floatBits (D# d#) = W64# (unsafeCoerce# d#) + +floatOfBits :: Word64 -> Double +floatOfBits (W64# b#) = D# (unsafeCoerce# b#) + diff --git a/src/Thrift/Server.hs b/src/Thrift/Server.hs new file mode 100644 --- /dev/null +++ b/src/Thrift/Server.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- +-- 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.Server + ( runBasicServer + , runThreadedServer + ) where + +import Control.Concurrent ( forkIO ) +import Control.Exception +import Control.Monad ( forever, when ) + +import Network + +import System.IO + +import Thrift +import Thrift.Transport.Handle() +import Thrift.Protocol.Binary + + +-- | A threaded sever that is capable of using any Transport or Protocol +-- instances. +runThreadedServer :: (Transport t, Protocol i, Protocol o) + => (Socket -> IO (i t, o t)) + -> h + -> (h -> (i t, o t) -> IO Bool) + -> PortID + -> IO a +runThreadedServer accepter hand proc_ port = do + socket <- listenOn port + acceptLoop (accepter socket) (proc_ hand) + +-- | A basic threaded binary protocol socket server. +runBasicServer :: h + -> (h -> (BinaryProtocol Handle, BinaryProtocol Handle) -> IO Bool) + -> PortNumber + -> IO a +runBasicServer hand proc_ port = runThreadedServer binaryAccept hand proc_ (PortNumber port) + where binaryAccept s = do + (h, _, _) <- accept s + return (BinaryProtocol h, BinaryProtocol h) + +acceptLoop :: IO t -> (t -> IO Bool) -> IO a +acceptLoop accepter proc_ = forever $ + do ps <- accepter + forkIO $ handle (\(_ :: SomeException) -> return ()) + (loop $ proc_ ps) + where loop m = do { continue <- m; when continue (loop m) } diff --git a/src/Thrift/Transport.hs b/src/Thrift/Transport.hs new file mode 100644 --- /dev/null +++ b/src/Thrift/Transport.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-- +-- 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 + ( Transport(..) + , TransportExn(..) + , TransportExnType(..) + ) where + +import Control.Monad ( when ) +import Control.Exception ( Exception, throw ) + +import Data.Typeable ( Typeable ) + +import qualified Data.ByteString.Lazy as LBS +import Data.Monoid + +class Transport a where + tIsOpen :: a -> IO Bool + tClose :: a -> IO () + tRead :: a -> Int -> IO LBS.ByteString + tWrite :: a -> LBS.ByteString -> IO () + tFlush :: a -> IO () + tReadAll :: a -> Int -> IO LBS.ByteString + + tReadAll _ 0 = return mempty + tReadAll a len = do + result <- tRead a len + 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)) + +data TransportExn = TransportExn String TransportExnType + deriving ( Show, Typeable ) +instance Exception TransportExn + +data TransportExnType + = TE_UNKNOWN + | TE_NOT_OPEN + | TE_ALREADY_OPEN + | TE_TIMED_OUT + | TE_END_OF_FILE + deriving ( Eq, Show, Typeable ) + diff --git a/src/Thrift/Transport/Handle.hs b/src/Thrift/Transport/Handle.hs new file mode 100644 --- /dev/null +++ b/src/Thrift/Transport/Handle.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- +-- 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.Handle + ( module Thrift.Transport + , HandleSource(..) + ) where + +import Control.Exception ( throw ) +import Control.Monad () + +import Network + +import System.IO +import System.IO.Error ( isEOFError ) + +import Thrift.Transport + +import qualified Data.ByteString.Lazy as LBS +import Data.Monoid + +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 + tFlush = hFlush + + +-- | Type class for all types that can open a Handle. This class is used to +-- replace tOpen in the Transport type class. +class HandleSource s where + hOpen :: s -> IO Handle + +instance HandleSource FilePath where + hOpen s = openFile s ReadWriteMode + +instance HandleSource (HostName, PortID) where + hOpen = uncurry connectTo + + +handleEOF :: forall a (m :: * -> *).(Monoid a, Monad m) => IOError -> m a +handleEOF e = if isEOFError e + then return mempty + else throw $ TransportExn "TChannelTransport: Could not read" TE_UNKNOWN diff --git a/src/Thrift/Transport/HttpClient.hs b/src/Thrift/Transport/HttpClient.hs new file mode 100644 --- /dev/null +++ b/src/Thrift/Transport/HttpClient.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE FlexibleInstances #-} +-- +-- 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.HttpClient + ( module Thrift.Transport + , HttpClient (..) + , openHttpClient + ) where + +import Thrift.Transport +import Network.URI +import Network.HTTP hiding (port, host) + +import Control.Monad (liftM) +import Data.Maybe (fromJust) +import Data.Monoid (mappend, mempty) +import Control.Exception (throw) +import Control.Concurrent.MVar +import qualified Data.Binary.Builder as B +import qualified Data.ByteString.Lazy as LBS + + +-- | 'HttpClient', or THttpClient implements the Thrift Transport +-- | Layer over http or https. +data HttpClient = + HttpClient { + hstream :: HandleStream LBS.ByteString, + uri :: URI, + writeBuffer :: WriteBuffer, + readBuffer :: ReadBuffer + } + +uriAuth :: URI -> URIAuth +uriAuth = fromJust . uriAuthority + +host :: URI -> String +host = uriRegName . uriAuth + +port :: URI -> Int +port uri_ = + if portStr == mempty then + httpPort + else + read portStr + where + portStr = dropWhile (== ':') $ uriPort $ uriAuth uri_ + httpPort = 80 + +-- | Use 'openHttpClient' to create an HttpClient connected to @uri@ +openHttpClient :: URI -> IO HttpClient +openHttpClient uri_ = do + stream <- openTCPConnection (host uri_) (port uri_) + wbuf <- newWriteBuffer + rbuf <- newReadBuffer + return $ HttpClient stream uri_ wbuf rbuf + +instance Transport HttpClient where + + tClose = close . hstream + + tRead hclient n = readBuf (readBuffer hclient) n + + tWrite hclient = writeBuf (writeBuffer hclient) + + tFlush hclient = do + body <- flushBuf $ writeBuffer hclient + let request = Request { + rqURI = uri hclient, + rqHeaders = [ + mkHeader HdrContentType "application/x-thrift", + mkHeader HdrContentLength $ show $ LBS.length body], + rqMethod = POST, + rqBody = body + } + + res <- sendHTTP (hstream hclient) request + case res of + Right response -> do + fillBuf (readBuffer hclient) (rspBody response) + Left _ -> do + 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) diff --git a/thrift.cabal b/thrift.cabal new file mode 100644 --- /dev/null +++ b/thrift.cabal @@ -0,0 +1,47 @@ +-- +-- 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. +-- + +Name: thrift +Version: 0.6.0 +Cabal-Version: >= 1.4 +License: OtherLicense +Category: Foreign +Build-Type: Simple +Synopsis: Haskell bindings for the Apache Thrift RPC system +Homepage: http://thrift.apache.org +Bug-Reports: https://issues.apache.org/jira/browse/THRIFT +Maintainer: dev@thrift.apache.org +License-File: LICENSE + +Description: + Haskell bindings for the Apache Thrift RPC system. Requires the use of the thrift code generator. + +Library + Hs-Source-Dirs: + src + Build-Depends: + base >= 4, base < 5, network, ghc-prim, binary, bytestring, HTTP + Exposed-Modules: + Thrift, Thrift.Protocol, Thrift.Transport, Thrift.Protocol.Binary + Thrift.Transport.Handle, Thrift.Transport.HttpClient, Thrift.Server + Extensions: + DeriveDataTypeable, ExistentialQuantification, FlexibleInstances, + KindSignatures, MagicHash, RankNTypes, + ScopedTypeVariables, TypeSynonymInstances +