diff --git a/compiler/cpp/src/generate/t_hs_generator.cc b/compiler/cpp/src/generate/t_hs_generator.cc index 18b90c11a..ee1783955 100644 --- a/compiler/cpp/src/generate/t_hs_generator.cc +++ b/compiler/cpp/src/generate/t_hs_generator.cc @@ -211,7 +211,7 @@ string t_hs_generator::hs_autogen_comment() { * Prints standard thrift imports */ string t_hs_generator::hs_imports() { - return "import Thrift\nimport Data.Generics\nimport Control.Exception\nimport qualified Data.Map as Map\nimport qualified Data.Set as Set\nimport Data.Int"; + return "import Thrift\nimport Data.Typeable ( Typeable )\nimport Control.Exception\nimport qualified Data.Map as Map\nimport qualified Data.Set as Set\nimport Data.Int"; } /** @@ -253,7 +253,7 @@ void t_hs_generator::generate_enum(t_enum* tenum) { f_types_ << "|"; f_types_ << name; } - indent(f_types_) << "deriving (Show,Eq, Typeable, Data, Ord)" << endl; + indent(f_types_) << "deriving (Show,Eq, Typeable, Ord)" << endl; indent_down(); int value = -1; @@ -287,7 +287,7 @@ void t_hs_generator::generate_enum(t_enum* tenum) { f_types_ << indent() << value << " -> " << name << endl; } - indent(f_types_) << "_ -> throwDyn Thrift_Error" << endl; + indent(f_types_) << "_ -> throw ThriftException" << endl; indent_down(); indent_down(); } @@ -487,7 +487,7 @@ void t_hs_generator::generate_hs_struct_definition(ofstream& out, } out << " deriving (Show,Eq,Ord,Typeable)" << endl; - + if (is_exception) out << "instance Exception " << tname << endl; generate_hs_struct_writer(out, tstruct); generate_hs_struct_reader(out, tstruct); @@ -810,7 +810,7 @@ void t_hs_generator::generate_service_client(t_service* tservice) { // Write to the stream f_client_ << indent() << "writeMessageEnd op" << endl << - indent() << "tflush (getTransport op)" << endl; + indent() << "tFlush (getTransport op)" << endl; indent_down(); @@ -837,7 +837,7 @@ void t_hs_generator::generate_service_client(t_service* tservice) { indent() << " x <- readAppExn ip" << endl << indent() << " readMessageEnd ip" << endl; f_client_ << - indent() << " throwDyn x" << endl; + indent() << " throw x" << endl; f_client_ << indent() << " else return ()" << endl; @@ -866,7 +866,7 @@ void t_hs_generator::generate_service_client(t_service* tservice) { indent() << "case f_"<< resultname << "_" << (*x_iter)->get_name() << " res of" << endl; indent_up(); //case indent(f_client_) << "Nothing -> return ()" << endl; - indent(f_client_) << "Just _v -> throwDyn _v" << endl; + indent(f_client_) << "Just _v -> throw _v" << endl; indent_down(); //-case } @@ -876,7 +876,7 @@ void t_hs_generator::generate_service_client(t_service* tservice) { "return ()" << endl; } else { f_client_ << - indent() << "throwDyn (AppExn AE_MISSING_RESULT \"" << (*f_iter)->get_name() << " failed: unknown result\")" << endl; + indent() << "throw (AppExn AE_MISSING_RESULT \"" << (*f_iter)->get_name() << " failed: unknown result\")" << endl; indent_down(); //-none indent_down(); //-case } @@ -923,7 +923,7 @@ void t_hs_generator::generate_service_server(t_service* tservice) { indent(f_service_) << "writeMessageBegin oprot (name,M_EXCEPTION,seqid)" << endl; indent(f_service_) << "writeAppExn oprot (AppExn AE_UNKNOWN_METHOD (\"Unknown function \" ++ name))" << endl; indent(f_service_) << "writeMessageEnd oprot" << endl; - indent(f_service_) << "tflush (getTransport oprot)" << endl; + indent(f_service_) << "tFlush (getTransport oprot)" << endl; indent_down(); } indent_down(); @@ -987,7 +987,7 @@ void t_hs_generator::generate_process_function(t_service* tservice, // Try block for a function with exceptions if (xceptions.size() > 0) { for(unsigned int i=0;iget_name() << "\", M_REPLY, seqid);" << endl << indent() << "write_"<= 1.2 +License: Apache2 Category: Foreign Build-Type: Simple Synopsis: Thrift library package @@ -9,10 +10,11 @@ Library Hs-Source-Dirs: src Build-Depends: - base <4 && >2, network, ghc-prim + base >=4, network, ghc-prim ghc-options: -fglasgow-exts Extensions: DeriveDataTypeable Exposed-Modules: - Thrift, TBinaryProtocol, TChannelTransport, TServer, TSocket + Thrift, Thrift.Protocol, Thrift.Transport, Thrift.Protocol.Binary + Thrift.Transport.Handle, Thrift.Server diff --git a/lib/hs/src/TBinaryProtocol.hs b/lib/hs/src/TBinaryProtocol.hs deleted file mode 100644 index ed2151b24..000000000 --- a/lib/hs/src/TBinaryProtocol.hs +++ /dev/null @@ -1,132 +0,0 @@ --- --- 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 TBinaryProtocol (TBinaryProtocol(..)) where - import Thrift - import Data.Bits - import Data.Int - import GHC.Exts - import GHC.Prim - import GHC.Word - import Control.Exception - - data TBinaryProtocol a = TTransport a => TBinaryProtocol a - - version_mask = 0xffff0000 - version_1 = 0x80010000; - - getByte :: Bits a => a -> Int -> a - getByte i b = 255 .&. (shiftR i (8*b)) - - 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#) - - composeBytesH :: [Char] -> Int -> Word32 - composeBytesH [] n = 0 - composeBytesH (h:t) n = (shiftL (fromIntegral (fromEnum h) :: Word32) (8*n)) .|. (composeBytesH t (n-1)) - compBytes :: [Char] -> Word32 - compBytes b = composeBytesH b ((length b)-1) - - composeBytes64H :: [Char] -> Int -> Word64 - composeBytes64H [] n = 0 - composeBytes64H (h:t) n = (shiftL (fromIntegral (fromEnum h) :: Word64) (8*n)) .|. (composeBytes64H t (n-1)) - compBytes64 :: [Char] -> Word64 - compBytes64 b = composeBytes64H b ((length b)-1) - instance Protocol TBinaryProtocol where - getTransport (TBinaryProtocol t) = t - writeBool (TBinaryProtocol tr) b = twrite tr (if b then [toEnum 1::Char] else [toEnum 0::Char]) - writeByte (TBinaryProtocol tr) b = twrite tr (getBytes b 1) - writeI16 (TBinaryProtocol tr) b = twrite tr (getBytes b 2) - writeI32 (TBinaryProtocol tr) b = twrite tr (getBytes b 4) - writeI64 (TBinaryProtocol tr) b = twrite tr (getBytes b 8) - writeDouble (TBinaryProtocol tr) b = writeI64 (TBinaryProtocol tr) (fromIntegral (floatBits b) :: Int64) - writeString (TBinaryProtocol tr) s = do twrite tr (getBytes (length s) 4) - twrite tr s - writeBinary = writeString - writeMessageBegin (TBinaryProtocol tr) (n,t,s) = do writeI32 (TBinaryProtocol tr) (version_1 .|. (fromEnum t)) - writeString (TBinaryProtocol tr) n - writeI32 (TBinaryProtocol tr) s - writeMessageEnd (TBinaryProtocol tr) = return () - writeStructBegin (TBinaryProtocol tr) s = return () - writeStructEnd (TBinaryProtocol tr) = return () - writeFieldBegin a (n,t,i) = do writeByte a (fromEnum t) - writeI16 a i - writeFieldEnd a = return () - writeFieldStop a = writeByte a (fromEnum T_STOP) - writeMapBegin a (k,v,s) = do writeByte a (fromEnum k) - writeByte a (fromEnum v) - writeI32 a s - writeMapEnd a = return () - writeListBegin a (t,s) = do writeByte a (fromEnum t) - writeI32 a s - writeListEnd a = return () - writeSetBegin = writeListBegin - writeSetEnd a = return () - readByte (TBinaryProtocol tr) = do b <- treadAll tr 1 - return $ (fromIntegral (fromIntegral (compBytes b) :: Int8) :: Int) - readI16 (TBinaryProtocol tr) = do b <- treadAll tr 2 - return $ (fromIntegral (fromIntegral (compBytes b) :: Int16) :: Int) - readI32 (TBinaryProtocol tr) = do b <- treadAll tr 4 - return $ (fromIntegral (fromIntegral (compBytes b) :: Int32) :: Int) - readI64 (TBinaryProtocol tr) = do b <- treadAll tr 8 - return $ (fromIntegral (compBytes64 b) :: Int64) - readDouble (TBinaryProtocol tr) = do b <- readI64 (TBinaryProtocol tr) - return $ floatOfBits (fromIntegral b :: Word64) - readBool (TBinaryProtocol tr) = do b <- readByte (TBinaryProtocol tr) - return $ b == 1 - readString (TBinaryProtocol tr) = do l <- readI32 (TBinaryProtocol tr) - treadAll tr l - readBinary = readString - readMessageBegin (TBinaryProtocol tr) = do ver <- readI32 (TBinaryProtocol tr) - if (ver .&. version_mask /= version_1) then - throwDyn (ProtocolExn PE_BAD_VERSION "Missing version identifier") - else do - s <- readString (TBinaryProtocol tr) - sz <- readI32 (TBinaryProtocol tr) - return (s,toEnum (ver .&. 0xFF) :: Message_type,fromIntegral sz :: Int) - readMessageEnd (TBinaryProtocol tr) = return () - readStructBegin (TBinaryProtocol tr) = return "" - readStructEnd (TBinaryProtocol tr) = return () - readFieldBegin (TBinaryProtocol tr) = do t <- readByte (TBinaryProtocol tr) - if (toEnum t :: T_type) /= T_STOP then - do s <- readI16 (TBinaryProtocol tr) - return ("",toEnum t :: T_type,fromIntegral s :: Int) - else return ("",toEnum t :: T_type,0) - readFieldEnd (TBinaryProtocol tr) = return () - readMapBegin a = do kt <- readByte a - vt <- readByte a - s <- readI32 a - return (toEnum kt :: T_type,toEnum vt :: T_type,fromIntegral s :: Int) - readMapEnd a = return () - readListBegin a = do b <- readByte a - s <- readI32 a - return (toEnum b :: T_type,fromIntegral s :: Int) - readListEnd a = return () - readSetBegin = readListBegin - readSetEnd = readListEnd - - - diff --git a/lib/hs/src/TChannelTransport.hs b/lib/hs/src/TChannelTransport.hs deleted file mode 100644 index b67751af9..000000000 --- a/lib/hs/src/TChannelTransport.hs +++ /dev/null @@ -1,45 +0,0 @@ --- --- 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 TChannelTransport(TChannelTrans(..)) where - -import Thrift -import Control.Exception - -import System.IO -import System.IO.Error ( isEOFError ) - - -data TChannelTrans = TChannelTrans (Handle) - -instance TTransport TChannelTrans where - tisOpen a = True - topen a = return a - tclose a = return a - tread a 0 = return [] - tread (TChannelTrans h) i = Prelude.catch - (do c <- hGetChar h - t <- tread (TChannelTrans h) (i-1) - return $ c:t) - (\e -> if isEOFError e then return [] else throwDyn (TransportExn "TChannelTransport: Could not read" TE_UNKNOWN)) - twrite a [] = return () - twrite (TChannelTrans h) (c:t) = do hPutChar h c - twrite (TChannelTrans h) t - tflush (TChannelTrans h) = hFlush h - diff --git a/lib/hs/src/TServer.hs b/lib/hs/src/TServer.hs deleted file mode 100644 index bce29ba66..000000000 --- a/lib/hs/src/TServer.hs +++ /dev/null @@ -1,48 +0,0 @@ --- --- 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 TServer(run_basic_server,run_threaded_server) where - -import Network -import Thrift -import Control.Exception -import TBinaryProtocol -import TChannelTransport -import Control.Concurrent - -proc_loop hand proc ps = do v <-proc hand ps - if v then proc_loop hand proc ps - else return () - -accept_loop accepter hand sock proc transgen iprotgen oprotgen = - do (h,hn,_) <- accepter sock - let t = transgen h - let ip = iprotgen t - let op = oprotgen t - forkIO (handle (\e -> return ()) (proc_loop hand proc (ip,op))) - accept_loop accepter hand sock proc transgen iprotgen oprotgen - -run_threaded_server accepter listener hand proc port transgen iprotgen oprotgen = - do sock <- listener - accept_loop accepter hand sock proc transgen iprotgen oprotgen - return () - - --- A basic threaded binary protocol socket server. -run_basic_server hand proc port = run_threaded_server accept (listenOn (PortNumber port)) hand proc port TChannelTrans TBinaryProtocol TBinaryProtocol diff --git a/lib/hs/src/TSocket.hs b/lib/hs/src/TSocket.hs deleted file mode 100644 index 1e00261d1..000000000 --- a/lib/hs/src/TSocket.hs +++ /dev/null @@ -1,56 +0,0 @@ --- --- 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 TSocket(TSocket(..)) where - -import Thrift -import Data.IORef -import Network -import Control.Exception - -import System.IO - - -data TSocket = TSocket{host::[Char],port::PortNumber,chan :: Maybe Handle} - -instance TTransport TSocket where - tisOpen a = case chan a of - Just _ -> True - Nothing -> False - topen a = do h <- connectTo (host a) (PortNumber (port a)) - return $ (a{chan = Just h}) - tclose a = case chan a of - Just h -> do hClose h - return $ a{chan=Nothing} - Nothing -> return a - tread a 0 = return [] - tread a n = case chan a of - Just h -> handle (\e -> throwDyn (TransportExn "TSocket: Could not read." TE_UNKNOWN)) - (do c <- hGetChar h - l <- tread a (n-1) - return $ c:l) - Nothing -> return [] - twrite a s = case chan a of - Just h -> hPutStr h s - Nothing -> return () - tflush a = case chan a of - Just h -> hFlush h - Nothing -> return () - - diff --git a/lib/hs/src/Thrift.hs b/lib/hs/src/Thrift.hs index 293edf157..291bcae53 100644 --- a/lib/hs/src/Thrift.hs +++ b/lib/hs/src/Thrift.hs @@ -17,304 +17,95 @@ -- under the License. -- -module Thrift (TransportExn(..),TransportExn_Type(..),TTransport(..), T_type(..), Message_type(..), Protocol(..), AE_type(..), AppExn(..), readAppExn,writeAppExn,Thrift_exception(..), ProtocolExn(..), PE_type(..)) where - import Data.Generics - import Data.Int - import Control.Exception +module Thrift + ( module Thrift.Transport + , module Thrift.Protocol + , AppExnType(..) + , AppExn(..) + , readAppExn + , writeAppExn + , ThriftException(..) + ) where - data Thrift_exception = Thrift_Error deriving Typeable +import Control.Monad ( when ) +import Control.Exception - data TransportExn_Type = TE_UNKNOWN - | TE_NOT_OPEN - | TE_ALREADY_OPEN - | TE_TIMED_OUT - | TE_END_OF_FILE - deriving (Eq,Typeable,Show) +import Data.Typeable ( Typeable ) - data TransportExn = TransportExn [Char] TransportExn_Type deriving (Show,Typeable) - - class TTransport a where - tisOpen :: a -> Bool - topen :: a -> IO a - tclose :: a -> IO a - tread :: a -> Int -> IO [Char] - twrite :: a -> [Char] ->IO () - tflush :: a -> IO () - treadAll :: a -> Int -> IO [Char] - treadAll a 0 = return [] - treadAll a len = - do ret <- tread a len - case ret of - [] -> throwDyn (TransportExn "Cannot read. Remote side has closed." TE_UNKNOWN) - _ -> do - rl <- return (length ret) - if len <= rl then - return ret - else do r <- treadAll a (len-rl) - return (ret++r) +import Thrift.Transport +import Thrift.Protocol - data T_type = T_STOP - | T_VOID - | T_BOOL - | T_BYTE - | T_I08 - | T_I16 - | T_I32 - | T_U64 - | T_I64 - | T_DOUBLE - | T_STRING - | T_UTF7 - | T_STRUCT - | T_MAP - | T_SET - | T_LIST - | T_UTF8 - | T_UTF16 - | T_UNKNOWN - deriving (Eq) - instance Enum T_type where - fromEnum t = case t of - T_STOP -> 0 - T_VOID -> 1 - T_BOOL -> 2 - T_BYTE -> 3 - T_I08 -> 3 - T_I16 -> 6 - T_I32 -> 8 - T_U64 -> 9 - T_I64 -> 10 - T_DOUBLE -> 4 - T_STRING -> 11 - T_UTF7 -> 11 - T_STRUCT -> 12 - T_MAP -> 13 - T_SET -> 14 - T_LIST -> 15 - T_UTF8 -> 16 - T_UTF16 -> 17 - T_UNKNOWN -> -1 - toEnum t = case t of - 0 -> T_STOP - 1 -> T_VOID - 2 -> T_BOOL - 3 -> T_BYTE - 6-> T_I16 - 8 -> T_I32 - 9 -> T_U64 - 10 -> T_I64 - 4 -> T_DOUBLE - 11 -> T_STRING - 12 -> T_STRUCT - 13 -> T_MAP - 14 -> T_SET - 15 -> T_LIST - 16 -> T_UTF8 - 17 -> T_UTF16 - _ -> T_UNKNOWN +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 ) - data Message_type = M_CALL - | M_REPLY - | M_EXCEPTION - | M_ONEWAY - | M_UNKNOWN - deriving Eq - instance Enum Message_type where +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 - fromEnum t = case t of - M_CALL -> 1 - M_REPLY -> 2 - M_EXCEPTION -> 3 - M_ONEWAY -> 4 - M_UNKNOWN -> -1 + 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 - toEnum t = case t of - 1 -> M_CALL - 2 -> M_REPLY - 3 -> M_EXCEPTION - 4 -> M_ONEWAY - _ -> M_UNKNOWN +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 (fromEnum (ae_type ae)) + writeFieldEnd pt + writeFieldStop pt + writeStructEnd pt - class Protocol a where - getTransport :: TTransport t => a t -> t - writeMessageBegin :: TTransport t => a t -> ([Char],Message_type,Int) -> IO () - writeMessageEnd :: TTransport t => a t -> IO () - writeStructBegin :: TTransport t => a t -> [Char] -> IO () - writeStructEnd :: TTransport t => a t -> IO () - writeFieldBegin :: TTransport t => a t -> ([Char], T_type,Int) -> IO () - writeFieldEnd :: TTransport t => a t -> IO () - writeFieldStop :: TTransport t => a t -> IO () - writeMapBegin :: TTransport t => a t -> (T_type,T_type,Int) -> IO () - writeMapEnd :: TTransport t => a t -> IO () - writeListBegin :: TTransport t => a t -> (T_type,Int) -> IO () - writeListEnd :: TTransport t => a t -> IO () - writeSetBegin :: TTransport t => a t -> (T_type,Int) -> IO () - writeSetEnd :: TTransport t => a t -> IO () - writeBool :: TTransport t => a t -> Bool -> IO () - writeByte :: TTransport t => a t -> Int -> IO () - writeI16 :: TTransport t => a t -> Int -> IO () - writeI32 :: TTransport t => a t -> Int -> IO () - writeI64 :: TTransport t => a t -> Int64 -> IO () - writeDouble :: TTransport t => a t -> Double -> IO () - writeString :: TTransport t => a t -> [Char] -> IO () - writeBinary :: TTransport t => a t -> [Char] -> IO () - readMessageBegin :: TTransport t => a t -> IO ([Char],Message_type,Int) - readMessageEnd :: TTransport t => a t -> IO () - readStructBegin :: TTransport t => a t -> IO [Char] - readStructEnd :: TTransport t => a t -> IO () - readFieldBegin :: TTransport t => a t -> IO ([Char],T_type,Int) - readFieldEnd :: TTransport t => a t -> IO () - readMapBegin :: TTransport t => a t -> IO (T_type,T_type,Int) - readMapEnd :: TTransport t => a t -> IO () - readListBegin :: TTransport t => a t -> IO (T_type,Int) - readListEnd :: TTransport t => a t -> IO () - readSetBegin :: TTransport t => a t -> IO (T_type,Int) - readSetEnd :: TTransport t => a t -> IO () - readBool :: TTransport t => a t -> IO Bool - readByte :: TTransport t => a t -> IO Int - readI16 :: TTransport t => a t -> IO Int - readI32 :: TTransport t => a t -> IO Int - readI64 :: TTransport t => a t -> IO Int64 - readDouble :: TTransport t => a t -> IO Double - readString :: TTransport t => a t -> IO [Char] - readBinary :: TTransport t => a t -> IO [Char] - skipFields :: TTransport t => a t -> IO () - skipMapEntries :: TTransport t => a t -> Int -> T_type -> T_type -> IO () - skipSetEntries :: TTransport t => a t -> Int -> T_type -> IO () - skip :: TTransport t => a t -> T_type -> IO () - skipFields a = do (_,ty,_) <- readFieldBegin a - if ty == T_STOP then - return () - else do skip a ty - readFieldEnd a - skipFields a - skipMapEntries a n k v= if n == 0 then - return () - else do skip a k - skip a v - skipMapEntries a (n-1) k v - skipSetEntries a n k = if n == 0 then - return () - else do skip a k - skipSetEntries a (n-1) k - skip a typ = case typ of - T_STOP -> return () - T_VOID -> return () - T_BOOL -> do readBool a - return () - T_BYTE -> do readByte a - return () - T_I08 -> do readByte a - return () - T_I16 -> do readI16 a - return () - T_I32 -> do readI32 a - return () - T_U64 -> do readI64 a - return () - T_I64 -> do readI64 a - return () - T_DOUBLE -> do readDouble a - return () - T_STRING -> do readString a - return () - T_UTF7 -> return () - T_STRUCT -> do readStructBegin a - skipFields a - readStructEnd a - return () - T_MAP -> do (k,v,s) <- readMapBegin a - skipMapEntries a s k v - readMapEnd a - return () - T_SET -> do (ty,s) <- readSetBegin a - skipSetEntries a s ty - readSetEnd a - return () - T_LIST -> do (ty,s) <- readListBegin a - skipSetEntries a s ty - readListEnd a - return () - T_UTF8 -> return () - T_UTF16 -> return () - T_UNKNOWN -> return () - - - data PE_type = PE_UNKNOWN - | PE_INVALID_DATA - | PE_NEGATIVE_SIZE - | PE_SIZE_LIMIT - | PE_BAD_VERSION - deriving (Eq, Data, Typeable) - - data ProtocolExn = ProtocolExn PE_type [Char] deriving (Typeable, Data) - - data AE_type = AE_UNKNOWN - | AE_UNKNOWN_METHOD - | AE_INVALID_MESSAGE_TYPE - | AE_WRONG_METHOD_NAME - | AE_BAD_SEQUENCE_ID - | AE_MISSING_RESULT - deriving (Eq, Data, Typeable) - - instance Enum AE_type where - toEnum i = case i of - 0 -> AE_UNKNOWN - 1 -> AE_UNKNOWN_METHOD - 2 -> AE_INVALID_MESSAGE_TYPE - 3 -> AE_WRONG_METHOD_NAME - 4 -> AE_BAD_SEQUENCE_ID - 5 -> AE_MISSING_RESULT - _ -> AE_UNKNOWN - fromEnum t = case t of - AE_UNKNOWN -> 0 - AE_UNKNOWN_METHOD -> 1 - AE_INVALID_MESSAGE_TYPE -> 2 - AE_WRONG_METHOD_NAME -> 3 - AE_BAD_SEQUENCE_ID -> 4 - AE_MISSING_RESULT -> 5 - - data AppExn = AppExn {ae_type :: AE_type, ae_message :: [Char]} deriving (Typeable, Data) - - readAppExnFields pt rec = do (n,ft,id) <- readFieldBegin pt - if ft == T_STOP then return rec - else - case id of - 1 -> if ft == T_STRING then - do s <- readString pt - readAppExnFields pt rec{ae_message = s} - else do skip pt ft - readAppExnFields pt rec - 2 -> if ft == T_I32 then - do i <- readI32 pt - readAppExnFields pt rec{ae_type = (toEnum i)} - else do skip pt ft - readAppExnFields pt rec - _ -> do skip pt ft - readFieldEnd pt - readAppExnFields pt rec - - readAppExn pt = do readStructBegin pt - rec <- readAppExnFields pt (AppExn {ae_type = undefined, ae_message = undefined}) - readStructEnd pt - return rec - - - writeAppExn pt ae = do writeStructBegin pt "TApplicationException" - if ae_message ae /= "" then - do writeFieldBegin pt ("message",T_STRING,1) - writeString pt (ae_message ae) - writeFieldEnd pt - else return () - writeFieldBegin pt ("type",T_I32,2); - writeI32 pt (fromEnum (ae_type ae)) - writeFieldEnd pt - writeFieldStop pt - writeStructEnd pt +readAppExn :: (Protocol p, Transport t) => p t -> IO AppExn +readAppExn pt = do + readStructBegin pt + rec <- readAppExnFields pt (AppExn {ae_type = undefined, ae_message = undefined}) + readStructEnd pt + return rec +readAppExnFields pt rec = do + (n, ft, id) <- readFieldBegin pt + if ft == T_STOP + then return rec + else case id of + 1 -> if ft == T_STRING then + do s <- readString pt + readAppExnFields pt rec{ae_message = s} + else do skip pt ft + readAppExnFields pt rec + 2 -> if ft == T_I32 then + do i <- readI32 pt + readAppExnFields pt rec{ae_type = (toEnum i)} + else do skip pt ft + readAppExnFields pt rec + _ -> do skip pt ft + readFieldEnd pt + readAppExnFields pt rec 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 diff --git a/test/hs/Client.hs b/test/hs/Client.hs index 81d7f0f78..c5e4d9074 100644 --- a/test/hs/Client.hs +++ b/test/hs/Client.hs @@ -18,18 +18,25 @@ -- module Client where -import Thrift + import ThriftTest_Client import ThriftTest_Types -import TSocket -import TBinaryProtocol import qualified Data.Map as Map import qualified Data.Set as Set import Control.Monad -t = TSocket "127.0.0.1" 9090 Nothing +import Control.Exception as CE -main = do to <- topen t - let p = TBinaryProtocol to +import Network + +import Thrift +import Thrift.Transport.Handle +import Thrift.Protocol.Binary + + +serverAddress = ("127.0.0.1", PortNumber 9090) + +main = do to <- hOpen serverAddress + let p = BinaryProtocol to let ps = (p,p) print =<< testString ps "bya" print =<< testByte ps 8 @@ -44,5 +51,8 @@ main = do to <- topen t print =<< testList ps [1,2,3,4,5] print =<< testSet ps (Set.fromList [1,2,3,4,5]) print =<< testStruct ps (Xtruct (Just "hi") (Just 4) (Just 5) Nothing) - tclose to + CE.catch (testException ps "e" >> print "bad") (\e -> print (e :: Xception)) + CE.catch (testMultiException ps "e" "e2" >> print "ok") (\e -> print (e :: Xception)) + CE.catch (CE.catch (testMultiException ps "e" "e2">> print "bad") (\e -> print (e :: Xception2))) (\(e :: SomeException) -> print "ok") + tClose to diff --git a/test/hs/Server.hs b/test/hs/Server.hs index f9b333f0a..0ca9d9fea 100644 --- a/test/hs/Server.hs +++ b/test/hs/Server.hs @@ -18,14 +18,16 @@ -- module Server where -import Thrift + import ThriftTest import ThriftTest_Iface import Data.Map as Map -import TServer import Control.Exception import ThriftTest_Types +import Thrift +import Thrift.Server + data TestHandler = TestHandler instance ThriftTest_Iface TestHandler where @@ -45,9 +47,11 @@ instance ThriftTest_Iface TestHandler where testMapMap a (Just x) = return (Map.fromList [(1,Map.fromList [(2,2)])]) testInsanity a (Just x) = return (Map.fromList [(1,Map.fromList [(ONE,x)])]) testMulti a a1 a2 a3 a4 a5 a6 = return (Xtruct Nothing Nothing Nothing Nothing) - testException a c = throwDyn (Xception (Just 1) (Just "bya")) - testMultiException a c1 c2 = return (Xtruct Nothing Nothing Nothing Nothing) + testException a c = throw (Xception (Just 1) (Just "bya")) + testMultiException a c1 c2 = throw (Xception (Just 1) (Just "xyz")) testOneway a (Just i) = do print i -main = do (run_basic_server TestHandler process 9090) `catchDyn` (\(TransportExn s t) -> print s) +main = do (runBasicServer TestHandler process 9090) + `Control.Exception.catch` + (\(TransportExn s t) -> print s) diff --git a/test/hs/runclient.sh b/test/hs/runclient.sh index 98a3100e7..b93bbb147 100644 --- a/test/hs/runclient.sh +++ b/test/hs/runclient.sh @@ -19,12 +19,8 @@ # under the License. # -if [ -z $BASE_PKG ]; then - BASE_PKG=`ghc-pkg --simple-output list base-3* | sed -e "s/.*\(base-3\(.[0-9]\){3}\).*/\1/"` -fi - if [ -z $BASE ]; then BASE=../.. fi -ghci -fglasgow-exts -package $BASE_PKG -hide-package syb -i$BASE/lib/hs/src -i$BASE/test/hs/gen-hs Client.hs +ghci -fglasgow-exts -i$BASE/lib/hs/src -i$BASE/test/hs/gen-hs Client.hs diff --git a/test/hs/runserver.sh b/test/hs/runserver.sh index 93586653c..b23301b48 100644 --- a/test/hs/runserver.sh +++ b/test/hs/runserver.sh @@ -19,13 +19,9 @@ # under the License. # -if [ -z $BASE_PKG ]; then - BASE_PKG=`ghc-pkg --simple-output list base-3* | sed -e "s/.*\(base-3\(.[0-9]\){3}\).*/\1/"` -fi - if [ -z $BASE ]; then BASE=../.. fi printf "Starting server... " -ghc -fglasgow-exts -package $BASE_PKG -hide-package syb -i$BASE/lib/hs/src -i$BASE/test/hs/gen-hs Server.hs -e "putStrLn \"ready.\" >> Server.main" +ghc -fglasgow-exts -i$BASE/lib/hs/src -i$BASE/test/hs/gen-hs Server.hs -e "putStrLn \"ready.\" >> Server.main"