valitydev/thrift
14
0
Fork 0
mirror of https://github.com/valitydev/thrift.git synced 2024-11-07 02:45:22 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Thrift: Haskell library and codegen

Browse Source 
Summary: It's thrift for haskell. The codegen is complete. The library has binary protocol, io channel transport, and a threaded server.
Reviewed by: mcslee
Test plan: Yes
Revert plan: yes


git-svn-id: https://svn.apache.org/repos/asf/incubator/thrift/trunk@665174 13f79535-47bb-0310-9956-ffa450edef68
This commit is contained in:
iproctor 2007-07-25 19:06:13 +00:00
parent 5ced286cec
commit ff8eb9288d
15 changed files with 2084 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
compiler/cpp/Makefile.am
View File

@ -16,8 +16,8 @@ thrift_SOURCES = src/thrifty.yy \
src/generate/t_xsd_generator.cc \
src/generate/t_perl_generator.cc \
src/generate/t_ocaml_generator.cc \
src/generate/t_erl_generator.cc
src/generate/t_erl_generator.cc \
src/generate/t_hs_generator.cc
thrift_CXXFLAGS = -Wall -Isrc $(BOOST_CPPFLAGS)
thrift_LDFLAGS = -Wall $(BOOST_LDFLAGS)

1344
compiler/cpp/src/generate/t_hs_generator.cc Normal file
View File

File diff suppressed because it is too large Load Diff

144
compiler/cpp/src/generate/t_hs_generator.h Normal file
View File

@ -0,0 +1,144 @@
// Copyright (c) 2006- Facebook
// Distributed under the Thrift Software License
//
// See accompanying file LICENSE or visit the Thrift site at:
// http://developers.facebook.com/thrift/
#ifndef T_HS_GENERATOR_H
#define T_HS_GENERATOR_H
#include <string>
#include <fstream>
#include <iostream>
#include <vector>
#include "t_oop_generator.h"
#define T_HS_DIR "gen-hs"
/**
* Haskell code generator.
*
* @author Iain Proctor <iproctor@facebook.com>
*/
class t_hs_generator : public t_oop_generator {
public:
t_hs_generator(t_program* program) :
t_oop_generator(program) {}
/**
* Init and close methods
*/
void init_generator();
void close_generator();
/**
* Program-level generation functions
*/
void generate_program ();
void generate_typedef (t_typedef* ttypedef);
void generate_enum (t_enum* tenum);
void generate_const (t_const* tconst);
void generate_struct (t_struct* tstruct);
void generate_xception (t_struct* txception);
void generate_service (t_service* tservice);
std::string render_const_value(t_type* type, t_const_value* value);
/**
* Struct generation code
*/
void generate_hs_struct(t_struct* tstruct, bool is_exception);
void generate_hs_struct_definition(std::ofstream &out,t_struct* tstruct, bool is_xception=false,bool helper=false);
void generate_hs_struct_reader(std::ofstream& out, t_struct* tstruct);
void generate_hs_struct_writer(std::ofstream& out, t_struct* tstruct);
void generate_hs_function_helpers(t_function* tfunction);
/**
* Service-level generation functions
*/
void generate_service_helpers (t_service* tservice);
void generate_service_interface (t_service* tservice);
void generate_service_client (t_service* tservice);
void generate_service_server (t_service* tservice);
void generate_process_function (t_service* tservice, t_function* tfunction);
/**
* Serialization constructs
*/
void generate_deserialize_field (std::ofstream &out,
t_field* tfield,
std::string prefix);
void generate_deserialize_struct (std::ofstream &out,
t_struct* tstruct);
void generate_deserialize_container (std::ofstream &out,
t_type* ttype);
void generate_deserialize_set_element (std::ofstream &out,
t_set* tset);
void generate_deserialize_list_element (std::ofstream &out,
t_list* tlist,
std::string prefix="");
void generate_deserialize_type (std::ofstream &out,
t_type* type);
void generate_serialize_field (std::ofstream &out,
t_field* tfield,
std::string name= "");
void generate_serialize_struct (std::ofstream &out,
t_struct* tstruct,
std::string prefix="");
void generate_serialize_container (std::ofstream &out,
t_type* ttype,
std::string prefix="");
void generate_serialize_map_element (std::ofstream &out,
t_map* tmap,
std::string kiter,
std::string viter);
void generate_serialize_set_element (std::ofstream &out,
t_set* tmap,
std::string iter);
void generate_serialize_list_element (std::ofstream &out,
t_list* tlist,
std::string iter);
/**
* Helper rendering functions
*/
std::string hs_autogen_comment();
std::string hs_imports();
std::string type_name(t_type* ttype);
std::string function_type(t_function* tfunc, bool options = false, bool io = false, bool method = false);
std::string type_to_enum(t_type* ttype);
std::string render_hs_type(t_type* type);
private:
/**
* File streams
*/
std::ofstream f_types_;
std::ofstream f_consts_;
std::ofstream f_service_;
std::ofstream f_iface_;
std::ofstream f_client_;
};
#endif

14
compiler/cpp/src/main.cc
View File

@ -37,6 +37,7 @@
#include "generate/t_perl_generator.h"
#include "generate/t_ocaml_generator.h"
#include "generate/t_erl_generator.h"
#include "generate/t_hs_generator.h"
using namespace std;
@ -129,6 +130,7 @@ bool gen_rest = false;
bool gen_perl = false;
bool gen_ocaml = false;
bool gen_erl = false;
bool gen_hs = false;
bool gen_recurse = false;
/**
@ -308,6 +310,7 @@ void usage() {
fprintf(stderr, " -perl Generate Perl output files\n");
fprintf(stderr, " -ocaml Generate OCaml output files\n");
fprintf(stderr, " -erl Generate Erlang output files\n");
fprintf(stderr, " -hs Generate Haskell output files\n");
fprintf(stderr, " -I dir Add a directory to the list of directories \n");
fprintf(stderr, " searched for include directives\n");
fprintf(stderr, " -nowarn Suppress all compiler warnings (BAD!)\n");
@ -583,7 +586,12 @@ void generate(t_program* program) {
erl->generate_program();
delete erl;
}
if (gen_hs) {
pverbose("Generating Haskell\n");
t_hs_generator* hs = new t_hs_generator(program);
hs->generate_program();
delete hs;
}
} catch (string s) {
printf("Error: %s\n", s.c_str());
@ -653,6 +661,8 @@ int main(int argc, char** argv) {
gen_ocaml = true;
} else if (strcmp(arg, "-erl") == 0) {
gen_erl = true;
} else if (strcmp(arg, "-hs") == 0) {
gen_hs = true;
} else if (strcmp(arg, "-I") == 0) {
// An argument of "-I\ asdf" is invalid and has unknown results
arg = argv[++i];
@ -673,7 +683,7 @@ int main(int argc, char** argv) {
}
// You gotta generate something!
if (!gen_cpp && !gen_java && !gen_php && !gen_phpi && !gen_py && !gen_rb && !gen_xsd && !gen_perl && !gen_ocaml && !gen_erl) {
if (!gen_cpp && !gen_java && !gen_php && !gen_phpi && !gen_py && !gen_rb && !gen_xsd && !gen_perl && !gen_ocaml && !gen_erl && !gen_hs) {
fprintf(stderr, "!!! No output language(s) specified\n\n");
usage();
}

22
lib/hs/README Normal file
View File

@ -0,0 +1,22 @@
Haskell Thrift Bindings
Running: you need -fglasgow-exts.
Enums: become haskell data types. Use fromEnum to get out the int value.
Structs: become records. Field labels are ugly, of the form f_STRUCTNAME_FIELDNAME. All fields are Maybe types.
Exceptions: identical to structs. Throw them with throwDyn. Catch them with catchDyn.
Client: just a bunch of functions. You may have to import a bunch of client files to deal with inheritance.
Interface: You should only have to import the last one in the chain of inheritors. To make an interface, declare a label:
data MyIface = MyIface
and then declare it an instance of each iface class, starting with the superest class and proceding down (all the while defining the methods).
Then pass your label to process as the handler.
Processor: Just a function that takes a handler label, protocols. It calls the superclasses process if there is a superclass.
Note: Protocols implement flush as well as transports and do not have a getTransport method. This is because I couldn't get getTransport to typecheck. Shrug.

2
lib/hs/TODO Normal file
View File

@ -0,0 +1,2 @@
The library could stand to be built up more.
Many modules need export lists.

110
lib/hs/src/TBinaryProtocol.hs Normal file
View File

@ -0,0 +1,110 @@
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 i b= 255 .&. (shiftR i (8*b))
getBytes i 0 = []
getBytes i n = (toEnum (getByte i (n-1)) :: Char):(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 TTransport a => Protocol (TBinaryProtocol a) where
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) :: Int)
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 (fromIntegral (compBytes64 b) :: Int64) :: Int)
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
pflush (TBinaryProtocol tr) = tflush tr

22
lib/hs/src/TChannelTransport.hs Normal file
View File

@ -0,0 +1,22 @@
module TChannelTransport(TChannelTrans(..)) where
import System.IO
import IO
import Thrift
import Control.Exception
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

29
lib/hs/src/TServer.hs Normal file
View File

@ -0,0 +1,29 @@
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 hand sock proc transgen iprotgen oprotgen =
do (h,hn,_) <- accept 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 hand sock proc transgen iprotgen oprotgen
run_threaded_server hand proc port transgen iprotgen oprotgen =
do sock <- listenOn (PortNumber port)
accept_loop hand sock proc transgen iprotgen oprotgen
return ()
-- A basic threaded binary protocol socket server.
run_basic_server hand proc port = run_threaded_server hand proc port TChannelTrans TBinaryProtocol TBinaryProtocol

33
lib/hs/src/TSocket.hs Normal file
View File

@ -0,0 +1,33 @@
module TSocket(TSocket(..)) where
import Thrift
import Data.IORef
import Network
import IO
import Control.Exception
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 ()

298
lib/hs/src/Thrift.hs Normal file
View File

@ -0,0 +1,298 @@
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
data Thrift_exception = Thrift_Error deriving Typeable
data TransportExn_Type = TE_UNKNOWN
| TE_NOT_OPEN
| TE_ALREADY_OPEN
| TE_TIMED_OUT
| TE_END_OF_FILE
deriving (Eq,Typeable,Show)
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)
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 Message_type = M_CALL
| M_REPLY
| M_EXCEPTION
| M_UNKNOWN
deriving Eq
instance Enum Message_type where
fromEnum t = case t of
M_CALL -> 1
M_REPLY -> 2
M_EXCEPTION -> 3
M_UNKNOWN -> -1
toEnum t = case t of
1 -> M_CALL
2 -> M_REPLY
3 -> M_EXCEPTION
_ -> M_UNKNOWN
class Protocol a where
pflush :: a -> IO ()
writeMessageBegin :: a -> ([Char],Message_type,Int) -> IO ()
writeMessageEnd :: a -> IO ()
writeStructBegin :: a -> [Char] -> IO ()
writeStructEnd :: a -> IO ()
writeFieldBegin :: a -> ([Char], T_type,Int) -> IO ()
writeFieldEnd :: a -> IO ()
writeFieldStop :: a -> IO ()
writeMapBegin :: a -> (T_type,T_type,Int) -> IO ()
writeMapEnd :: a -> IO ()
writeListBegin :: a -> (T_type,Int) -> IO ()
writeListEnd :: a -> IO ()
writeSetBegin :: a -> (T_type,Int) -> IO ()
writeSetEnd :: a -> IO ()
writeBool :: a -> Bool -> IO ()
writeByte :: a -> Int -> IO ()
writeI16 :: a -> Int -> IO ()
writeI32 :: a -> Int -> IO ()
writeI64 :: a -> Int -> IO ()
writeDouble :: a -> Double -> IO ()
writeString :: a -> [Char] -> IO ()
writeBinary :: a -> [Char] -> IO ()
readMessageBegin :: a -> IO ([Char],Message_type,Int)
readMessageEnd :: a -> IO ()
readStructBegin :: a -> IO [Char]
readStructEnd :: a -> IO ()
readFieldBegin :: a -> IO ([Char],T_type,Int)
readFieldEnd :: a -> IO ()
readMapBegin :: a -> IO (T_type,T_type,Int)
readMapEnd :: a -> IO ()
readListBegin :: a -> IO (T_type,Int)
readListEnd :: a -> IO ()
readSetBegin :: a -> IO (T_type,Int)
readSetEnd :: a -> IO ()
readBool :: a -> IO Bool
readByte :: a -> IO Int
readI16 :: a -> IO Int
readI32 :: a -> IO Int
readI64 :: a -> IO Int
readDouble :: a -> IO Double
readString :: a -> IO [Char]
readBinary :: a -> IO [Char]
skipFields :: a -> IO ()
skipMapEntries :: a -> Int -> T_type -> T_type -> IO ()
skipSetEntries :: a -> Int -> T_type -> IO ()
skip :: a -> 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

29
test/hs/Client.hs Normal file
View File

@ -0,0 +1,29 @@
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
main = do to <- topen t
let p = TBinaryProtocol to
let ps = (p,p)
print =<< testString ps "bya"
print =<< testByte ps 8
print =<< testByte ps (-8)
print =<< testI32 ps 32
print =<< testI32 ps (-32)
print =<< testI64 ps 64
print =<< testI64 ps (-64)
print =<< testDouble ps 3.14
print =<< testDouble ps (-3.14)
print =<< testMap ps (Map.fromList [(1,1),(2,2),(3,3)])
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

33
test/hs/Server.hs Normal file
View File

@ -0,0 +1,33 @@
module Server where
import Thrift
import ThriftTest
import ThriftTest_Iface
import Data.Map as Map
import TServer
import Control.Exception
import ThriftTest_Types
data TestHandler = TestHandler
instance ThriftTest_Iface TestHandler where
testVoid a = return ()
testString a (Just s) = do print s; return s
testByte a (Just x) = do print x; return x
testI32 a (Just x) = do print x; return x
testI64 a (Just x) = do print x; return x
testDouble a (Just x) = do print x; return x
testStruct a (Just x) = do print x; return x
testNest a (Just x) = do print x; return x
testMap a (Just x) = do print x; return x
testSet a (Just x) = do print x; return x
testList a (Just x) = do print x; return x
testEnum a (Just x) = do print x; return x
testTypedef a (Just x) = do print x; return x
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)
main = do (run_basic_server TestHandler process 9090) `catchDyn` (\(TransportExn s t) -> print s)

2
test/hs/runclient.sh Normal file
View File

@ -0,0 +1,2 @@
#!/bin/bash
ghci -fglasgow-exts -i/home/iproctor/code/projects/thrift/trunk/lib/hs/src -igen-hs Client.hs

2
test/hs/runserver.sh Normal file
View File

@ -0,0 +1,2 @@
#!/bin/bash
ghci -fglasgow-exts -i/home/iproctor/code/projects/thrift/trunk/lib/hs/src -igen-hs Server.hs