| 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 | |
| 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 -> Int -> 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 Int | |
| 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 | |