diff options
Diffstat (limited to 'lib/hs/src/Thrift')
| -rw-r--r-- | lib/hs/src/Thrift/Protocol.hs | 191 | ||||
| -rw-r--r-- | lib/hs/src/Thrift/Protocol/Binary.hs | 147 | ||||
| -rw-r--r-- | lib/hs/src/Thrift/Server.hs | 65 | ||||
| -rw-r--r-- | lib/hs/src/Thrift/Transport.hs | 60 | ||||
| -rw-r--r-- | lib/hs/src/Thrift/Transport/Handle.hs | 58 |
5 files changed, 521 insertions, 0 deletions
diff --git a/lib/hs/src/Thrift/Protocol.hs b/lib/hs/src/Thrift/Protocol.hs new file mode 100644 index 000000000..8fa060ea5 --- /dev/null +++ b/lib/hs/src/Thrift/Protocol.hs @@ -0,0 +1,191 @@ +-- +-- 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.Typeable ( Typeable ) +import Data.Int + +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 + +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 + + +class Protocol a where + getTransport :: Transport t => a t -> t + + writeMessageBegin :: Transport t => a t -> (String, MessageType, Int) -> 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, Int) -> IO () + writeFieldEnd :: Transport t => a t -> IO () + writeFieldStop :: Transport t => a t -> IO () + writeMapBegin :: Transport t => a t -> (ThriftType, ThriftType, Int) -> IO () + writeMapEnd :: Transport t => a t -> IO () + writeListBegin :: Transport t => a t -> (ThriftType, Int) -> IO () + writeListEnd :: Transport t => a t -> IO () + writeSetBegin :: Transport t => a t -> (ThriftType, Int) -> IO () + writeSetEnd :: Transport t => a t -> IO () + + writeBool :: Transport t => a t -> Bool -> IO () + writeByte :: Transport t => a t -> Int -> IO () + writeI16 :: Transport t => a t -> Int -> IO () + writeI32 :: Transport t => a t -> Int -> 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 -> String -> IO () + + + readMessageBegin :: Transport t => a t -> IO (String, MessageType, Int) + 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, Int) + readFieldEnd :: Transport t => a t -> IO () + readMapBegin :: Transport t => a t -> IO (ThriftType, ThriftType, Int) + readMapEnd :: Transport t => a t -> IO () + readListBegin :: Transport t => a t -> IO (ThriftType, Int) + readListEnd :: Transport t => a t -> IO () + readSetBegin :: Transport t => a t -> IO (ThriftType, Int) + readSetEnd :: Transport t => a t -> IO () + + readBool :: Transport t => a t -> IO Bool + readByte :: Transport t => a t -> IO Int + readI16 :: Transport t => a t -> IO Int + readI32 :: Transport t => a t -> IO Int + 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 String + + +skip :: (Protocol p, Transport t) => p t -> ThriftType -> IO () +skip p T_STOP = return () +skip p 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_ s (skip p k >> skip p v) + readMapEnd p +skip p T_SET = do (t, n) <- readSetBegin p + replicateM_ n (skip p t) + readSetEnd p +skip p T_LIST = do (t, n) <- readListBegin p + replicateM_ 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/lib/hs/src/Thrift/Protocol/Binary.hs b/lib/hs/src/Thrift/Protocol/Binary.hs new file mode 100644 index 000000000..3f798ceea --- /dev/null +++ b/lib/hs/src/Thrift/Protocol/Binary.hs @@ -0,0 +1,147 @@ +-- +-- 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 Data.Bits +import Data.Int +import Data.List ( foldl' ) + +import GHC.Exts +import GHC.Word + +import Thrift.Protocol +import Thrift.Transport + + +version_mask = 0xffff0000 +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 .|. (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 p = 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) [toEnum $ if b then 1 else 0] + writeByte p b = tWrite (getTransport p) (getBytes b 1) + writeI16 p b = tWrite (getTransport p) (getBytes b 2) + writeI32 p b = tWrite (getTransport p) (getBytes b 4) + writeI64 p b = tWrite (getTransport p) (getBytes b 8) + writeDouble p d = writeI64 p (fromIntegral $ floatBits d) + writeString p s = writeI32 p (length s) >> tWrite (getTransport p) s + writeBinary = writeString + + 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 $ 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 $ fromIntegral (composeBytes bs :: Int8) + readI16 p = do + bs <- tReadAll (getTransport p) 2 + return $ fromIntegral (composeBytes bs :: Int16) + readI32 p = composeBytes `fmap` tReadAll (getTransport p) 4 + readI64 p = composeBytes `fmap` tReadAll (getTransport p) 8 + readDouble p = do + bs <- readI64 p + return $ floatOfBits $ fromIntegral bs + readString p = readI32 p >>= tReadAll (getTransport p) + readBinary = readString + + +-- | Write a type as a byte +writeType :: (Protocol p, Transport t) => p t -> ThriftType -> IO () +writeType p t = writeByte p (fromEnum t) + +-- | Read a byte as though it were a ThriftType +readType :: (Protocol p, Transport t) => p t -> IO ThriftType +readType p = toEnum `fmap` readByte p + +composeBytes :: (Bits b, Enum t) => [t] -> b +composeBytes = (foldl' fn 0) . (map $ fromIntegral . fromEnum) + where fn acc b = (acc `shiftL` 8) .|. b + +getByte :: Bits a => a -> Int -> a +getByte i n = 255 .&. (i `shiftR` (8 * n)) + +getBytes :: (Bits a, Integral a) => a -> Int -> String +getBytes i 0 = [] +getBytes i n = (toEnum $ fromIntegral $ getByte i (n-1)):(getBytes i (n-1)) + +floatBits :: Double -> Word64 +floatBits (D# d#) = W64# (unsafeCoerce# d#) + +floatOfBits :: Word64 -> Double +floatOfBits (W64# b#) = D# (unsafeCoerce# b#) + diff --git a/lib/hs/src/Thrift/Server.hs b/lib/hs/src/Thrift/Server.hs new file mode 100644 index 000000000..770965f1e --- /dev/null +++ b/lib/hs/src/Thrift/Server.hs @@ -0,0 +1,65 @@ +-- +-- 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 (\(e :: SomeException) -> return ()) + (loop $ proc ps) + where loop m = do { continue <- m; when continue (loop m) } diff --git a/lib/hs/src/Thrift/Transport.hs b/lib/hs/src/Thrift/Transport.hs new file mode 100644 index 000000000..29f50d07a --- /dev/null +++ b/lib/hs/src/Thrift/Transport.hs @@ -0,0 +1,60 @@ +-- +-- 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 ) + + +class Transport a where + tIsOpen :: a -> IO Bool + tClose :: a -> IO () + tRead :: a -> Int -> IO String + tWrite :: a -> String ->IO () + tFlush :: a -> IO () + tReadAll :: a -> Int -> IO String + + tReadAll a 0 = return [] + tReadAll a len = do + result <- tRead a len + let rlen = length result + when (rlen == 0) (throw $ TransportExn "Cannot read. Remote side has closed." TE_UNKNOWN) + if len <= rlen + then return result + else (result ++) `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/lib/hs/src/Thrift/Transport/Handle.hs b/lib/hs/src/Thrift/Transport/Handle.hs new file mode 100644 index 000000000..e49456b5b --- /dev/null +++ b/lib/hs/src/Thrift/Transport/Handle.hs @@ -0,0 +1,58 @@ +-- +-- 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 ( replicateM ) + +import Network + +import System.IO +import System.IO.Error ( isEOFError ) + +import Thrift.Transport + + +instance Transport Handle where + tIsOpen = hIsOpen + tClose h = hClose h + tRead h n = replicateM n (hGetChar h) `catch` handleEOF + tWrite h s = mapM_ (hPutChar 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 e = if isEOFError e + then return [] + else throw $ TransportExn "TChannelTransport: Could not read" TE_UNKNOWN |