mirror of
https://github.com/valitydev/thrift.git
synced 2024-11-07 02:45:22 +00:00
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
This commit is contained in:
Bryan Duxbury
parent
c8c088cc52
commit
0781f2b549
@ -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;i<xceptions.size();i++){
|
||||
f_service_ << "(catchDyn" << endl;
|
||||
f_service_ << "(Control.Exception.catch" << endl;
|
||||
indent_up();
|
||||
f_service_ << indent();
|
||||
}
|
||||
@ -1045,7 +1045,7 @@ void t_hs_generator::generate_process_function(t_service* tservice,
|
||||
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();
|
||||
|
||||
@ -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 @@ 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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
@ -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 ()
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
191
lib/hs/src/Thrift/Protocol.hs
Normal file
191
lib/hs/src/Thrift/Protocol.hs
Normal file
@ -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
|
||||
147
lib/hs/src/Thrift/Protocol/Binary.hs
Normal file
147
lib/hs/src/Thrift/Protocol/Binary.hs
Normal file
@ -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#)
|
||||
|
||||
65
lib/hs/src/Thrift/Server.hs
Normal file
65
lib/hs/src/Thrift/Server.hs
Normal file
@ -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) }
|
||||
60
lib/hs/src/Thrift/Transport.hs
Normal file
60
lib/hs/src/Thrift/Transport.hs
Normal file
@ -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 )
|
||||
|
||||
58
lib/hs/src/Thrift/Transport/Handle.hs
Normal file
58
lib/hs/src/Thrift/Transport/Handle.hs
Normal file
@ -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
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user