THRIFT-407. hs: Refactor and improve Haskell-related code
git-svn-id: https://svn.apache.org/repos/asf/incubator/thrift/trunk@763031 13f79535-47bb-0310-9956-ffa450edef68
diff --git a/compiler/cpp/src/generate/t_hs_generator.cc b/compiler/cpp/src/generate/t_hs_generator.cc
index 18b90c1..ee17839 100644
--- a/compiler/cpp/src/generate/t_hs_generator.cc
+++ b/compiler/cpp/src/generate/t_hs_generator.cc
@@ -211,7 +211,7 @@
* 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 @@
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 @@
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 @@
}
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 @@
// 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 @@
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 @@
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 @@
"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 @@
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 @@
// Try block for a function with exceptions
if (xceptions.size() > 0) {
for(unsigned int i=0;i<xceptions.size();i++){
- f_service_ << "(catchDyn" << endl;
+ f_service_ << "(Control.Exception.catch" << endl;
indent_up();
f_service_ << indent();
}
@@ -1045,7 +1045,7 @@
indent() << "writeMessageBegin oprot (\"" << tfunction->get_name() << "\", M_REPLY, seqid);" << endl <<
indent() << "write_"<<resultname<<" oprot res" << endl <<
indent() << "writeMessageEnd oprot" << endl <<
- indent() << "tflush (getTransport oprot)" << endl;
+ indent() << "tFlush (getTransport oprot)" << endl;
// Close function
indent_down();
diff --git a/lib/hs/Thrift.cabal b/lib/hs/Thrift.cabal
index 22f89b4..4cef4de 100644
--- a/lib/hs/Thrift.cabal
+++ b/lib/hs/Thrift.cabal
@@ -1,6 +1,7 @@
Name: Thrift
Version: 0.1.0
Cabal-Version: >= 1.2
+License: Apache2
Category: Foreign
Build-Type: Simple
Synopsis: Thrift library package
@@ -9,10 +10,11 @@
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 ed2151b..0000000
--- 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 b67751a..0000000
--- 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 bce29ba..0000000
--- 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 1e00261..0000000
--- 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 293edf1..291bcae 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 ()
+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
-
- 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
-
+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 0000000..8fa060e
--- /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 0000000..3f798ce
--- /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 0000000..770965f
--- /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 0000000..29f50d0
--- /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 0000000..e49456b
--- /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 81d7f0f..c5e4d90 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 @@
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 f9b333f..0ca9d9f 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 @@
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 98a3100..b93bbb1 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 9358665..b23301b 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"