Thrift: Haskell library and codegen
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
diff --git a/lib/hs/README b/lib/hs/README
new file mode 100644
index 0000000..d7b2232
--- /dev/null
+++ b/lib/hs/README
@@ -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.
+
diff --git a/lib/hs/TODO b/lib/hs/TODO
new file mode 100644
index 0000000..1368173
--- /dev/null
+++ b/lib/hs/TODO
@@ -0,0 +1,2 @@
+The library could stand to be built up more.
+Many modules need export lists.
diff --git a/lib/hs/src/TBinaryProtocol.hs b/lib/hs/src/TBinaryProtocol.hs
new file mode 100644
index 0000000..dd5212d
--- /dev/null
+++ b/lib/hs/src/TBinaryProtocol.hs
@@ -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
+
+
+
diff --git a/lib/hs/src/TChannelTransport.hs b/lib/hs/src/TChannelTransport.hs
new file mode 100644
index 0000000..df1aedc
--- /dev/null
+++ b/lib/hs/src/TChannelTransport.hs
@@ -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
+
diff --git a/lib/hs/src/TServer.hs b/lib/hs/src/TServer.hs
new file mode 100644
index 0000000..c71882c
--- /dev/null
+++ b/lib/hs/src/TServer.hs
@@ -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
diff --git a/lib/hs/src/TSocket.hs b/lib/hs/src/TSocket.hs
new file mode 100644
index 0000000..7e72878
--- /dev/null
+++ b/lib/hs/src/TSocket.hs
@@ -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 ()
+
+
diff --git a/lib/hs/src/Thrift.hs b/lib/hs/src/Thrift.hs
new file mode 100644
index 0000000..4087b2b
--- /dev/null
+++ b/lib/hs/src/Thrift.hs
@@ -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
+
+