diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,9 @@ +# Revision history for thrift-lib + +## 0.1.0.1 + +* Builds with GHC 9.8.x + +## 0.1.0.0 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +BSD License + +For hsthrift software + +Copyright (c) Facebook, Inc. and its affiliates. All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + * Neither the name Facebook nor the names of its contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +-- Copyright (c) Facebook, Inc. and its affiliates. + +-- @nolint +import Distribution.Simple +main = defaultMain diff --git a/Thrift/Api.hs b/Thrift/Api.hs new file mode 100644 --- /dev/null +++ b/Thrift/Api.hs @@ -0,0 +1,20 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Thrift.Api + ( Thrift + ) where + +import Thrift.Channel +import Thrift.Monad +import Thrift.Protocol + +-- | A thrift call across any protocol or channel for service `s` that returns +-- an`a` +type Thrift s a = + forall p c . (Protocol p, ClientChannel c) => ThriftM p c s a diff --git a/Thrift/Binary/Parser.hs b/Thrift/Binary/Parser.hs new file mode 100644 --- /dev/null +++ b/Thrift/Binary/Parser.hs @@ -0,0 +1,13 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Thrift.Binary.Parser + ( module Util.Binary.Parser + ) where + +import Util.Binary.Parser diff --git a/Thrift/Channel.hs b/Thrift/Channel.hs new file mode 100644 --- /dev/null +++ b/Thrift/Channel.hs @@ -0,0 +1,81 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# OPTIONS_GHC -Wno-star-is-type #-} +module Thrift.Channel + ( ClientChannel(..) + , SendCallback, RecvCallback + , Handle, mkCallbacks, wait + , Request(..), RpcOptions(..) + , Priority(..), Header + , defaultRpcOptions, simpleRequest + , Response(..), ChannelException(..) + ) where + +import Control.Exception hiding (handle) +import Control.Concurrent +import Control.Monad +import Data.ByteString (ByteString) +import Data.Text (Text) + +import Thrift.Monad + +-- Channels -------------------------------------------------------------------- + +class ClientChannel (c :: * -> *) where + sendRequest :: c t -> Request -> SendCallback -> RecvCallback -> IO () + sendOnewayRequest :: c t -> Request -> SendCallback -> IO () + +type SendCallback = Maybe ChannelException -> IO () +type RecvCallback = Either ChannelException Response -> IO () + +-- Default Callback Implementation with an MVar -------------------------------- + +type Handle a = MVar (Either SomeException a) + +mkCallbacks + :: (Response -> Either SomeException a) + -> IO (Handle a, SendCallback, RecvCallback) +mkCallbacks deserialize = do + handle <- newEmptyMVar + let + sendCob Nothing = return () + -- If there is a send error, then recv will never get called + sendCob (Just err) = putMVar handle (Left $ SomeException err) + + recvCob (Left err) = putMVar handle (Left $ SomeException err) + recvCob (Right r) = putMVar handle $ deserialize r + return (handle, sendCob, recvCob) + +wait :: Handle a -> IO a +wait = takeMVar >=> either throw return + +-- Requests -------------------------------------------------------------------- + +data Request = Request + { reqMsg :: !ByteString + , reqOptions :: !RpcOptions + } + +simpleRequest :: ByteString -> Request +simpleRequest bs = Request { reqMsg = bs + , reqOptions = defaultRpcOptions + } + +-- Responses ------------------------------------------------------------------- + +data Response = Response + { respMsg :: ByteString + , respHeader :: Header + } + +type Header = [(ByteString, ByteString)] + +newtype ChannelException = ChannelException Text + deriving (Show, Eq) +instance Exception ChannelException diff --git a/Thrift/Channel/SocketChannel.hs b/Thrift/Channel/SocketChannel.hs new file mode 100644 --- /dev/null +++ b/Thrift/Channel/SocketChannel.hs @@ -0,0 +1,157 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +-- | +-- An implementation of a Thrift channel in Haskell using +-- 'Network.Socket'. Note that the wire format of messages is not +-- necessarily compatible with other transports, in particular you +-- can't mix and match SocketChannel clients/servers with +-- HeaderChannel clients/servers. + +{-# LANGUAGE CPP #-} +module Thrift.Channel.SocketChannel + ( -- * Socket channel types and API + SocketChannel(..) + , SocketConfig(..) + , withSocketChannel + , withSocketChannelIO + + , -- * Utilities used by test servers + sendBS + , teardownSock + , threadWaitRecv + , recvBlockBytes + , localhost + ) where + +import Control.Concurrent +import Control.Exception +import Data.Proxy +import Network.Socket +import Network.Socket.ByteString +import System.Posix.Types (Fd(..)) +import qualified Data.ByteString as BS +import qualified Data.Text as T + +import Thrift.Channel +import Thrift.Monad +import Thrift.Protocol +import Thrift.Protocol.Id + +newtype SocketChannel t = SocketChannel Socket + +instance ClientChannel SocketChannel where + sendRequest ch@(SocketChannel sock) req sendcb recvcb = do + sendOnewayRequest ch req sendcb + recvRes <- try (threadWaitRecv sock recvBlockBytes) + case recvRes of + Right s -> recvcb (Right $ Response s mempty) + Left (e :: SomeException) -> + recvcb (Left $ ChannelException $ T.pack (show e)) + + sendOnewayRequest (SocketChannel sock) req sendcb = do + res <- sendBS sock (reqMsg req) + sendcb res + +data SocketConfig a = SocketConfig + { socketHost :: HostName + , socketPortNum :: PortNumber + , socketProtocolId :: ProtocolId + } + +deriving instance Show (SocketConfig a) + +-- | Given a 'SocketConfig' that specifies where to find the +-- server we want to reach and what protocol it uses, +-- connect to the server and run the given client +-- computation with it. +withSocketChannel + :: SocketConfig t + -> (forall p . Protocol p => ThriftM p SocketChannel t a) + -> IO a +withSocketChannel SocketConfig{..} f = + withSocketChannelIO socketHost socketPortNum $ \ch -> do + withProxy socketProtocolId (go ch f) + + where go :: Protocol p + => SocketChannel t + -> ThriftM p SocketChannel t a + -> Proxy p + -> IO a + go ch f _proxy = runThrift f ch + +-- | A lower level variant of 'withSocketChannel' that connects +-- to the server at the given host and port and passes the +-- resulting 'SocketChannel' to the third argument. +withSocketChannelIO + :: HostName + -> PortNumber + -> (SocketChannel t -> IO a) + -> IO a +withSocketChannelIO host port f = withSocketClient host port $ \sock _ -> + f (SocketChannel sock) + +sendBS :: Socket -> BS.ByteString -> IO (Maybe ChannelException) +sendBS sock bs = try (sendAll sock bs) >>= \res -> case res of + Left e -> return (Just e) + Right _ -> return Nothing + +-- | Block (using 'threadWaitRead') until some data is available, +-- and then call 'recv' to grab it. +threadWaitRecv + :: Socket + -> Int -- ^ max. number of bytes we want to receive + -> IO BS.ByteString +threadWaitRecv sock numBytes = withFdSocket sock $ \fd -> + threadWaitRead (Fd fd) >> recv sock numBytes + +withSocketClient + :: HostName + -> PortNumber + -> (Socket -> AddrInfo -> IO a) + -> IO a +withSocketClient host port f = withSocketsDo $ do + addr <- resolveClient host port + bracket (setupClientSock addr) teardownSock $ \sock -> + f sock addr + +setupClientSock :: AddrInfo -> IO Socket +setupClientSock addr = do + s <- openSocket addr + connect s (addrAddress addr) + return s + +teardownSock :: Socket -> IO () +teardownSock sock = shutdown sock ShutdownBoth `finally` close sock + +resolveClient :: HostName -> PortNumber -> IO AddrInfo +resolveClient host port = do + results <- getAddrInfo (Just hints) (Just host) (Just $ show port) + case results of + [] -> error $ "SocketChannel.resolveClient: " <> + "getAddrInfo returned an empty list" + (a:_) -> return a + + where hints = defaultHints { addrSocketType = Stream } + +localhost :: HostName +localhost = +#ifdef IPV4 + "127.0.0.1" +#else + "::1" +#endif + +recvBlockBytes :: Int +recvBlockBytes = 4096 + +#if !MIN_VERSION_network(3,1,2) +openSocket :: AddrInfo -> IO Socket +openSocket addr = + socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) +#endif diff --git a/Thrift/Channel/SocketChannel/Server.hs b/Thrift/Channel/SocketChannel/Server.hs new file mode 100644 --- /dev/null +++ b/Thrift/Channel/SocketChannel/Server.hs @@ -0,0 +1,249 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE CPP #-} +module Thrift.Channel.SocketChannel.Server + ( -- * High level interface to socket server implementation + withSocketServerOpts + , SocketServerOptions(..) + , defaultServerOptions + , SocketServer(..) + + , -- * Lower level interface + withServer + , withServerIO + ) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Exception +import Control.Monad +import Data.ByteString.Builder (toLazyByteString) +import Data.ByteString.Lazy (toStrict) +import Data.Maybe (fromMaybe) +import qualified Data.Map as Map +import Data.Proxy +import Network.Socket +import qualified Data.ByteString as BS +import qualified Data.Text as T + +import Thrift.Api +import Thrift.Binary.Parser +import Thrift.Channel.SocketChannel +import Thrift.Monad +import Thrift.Processor +import Thrift.Protocol +import Thrift.Protocol.ApplicationException.Types +import Thrift.Protocol.Id + +-- | +data SocketServerOptions = SocketServerOptions + { desiredPort :: Maybe Int + -- ^ lets the OS pick a port when 'Nothing' + , maxQueuedConns :: Maybe Int + -- ^ hint for the max number of connections for 'listen', + -- uses Network.Socket.maxListenQueue when Nothing + , protocol :: ProtocolId + -- ^ defaults to the binary protocol + } deriving (Eq, Show) + +-- | Default options: let the OS pick a port, use 'Network.Socket.maxListenQueue' +-- as the maximum number of queued connections, and communicate +-- with the binary Thrift protocol. +defaultServerOptions :: SocketServerOptions +defaultServerOptions = SocketServerOptions Nothing Nothing binaryProtocolId + +-- | Information about the running server given by 'withSocketServerOpts' +-- to the inner computation it runs against the server. +data SocketServer = SocketServer + { serverPort :: Int + , serverProt :: ProtocolId + } deriving (Eq, Show) + +-- | Highest level interface to the socket-based Thrift server +-- implementation. +withSocketServerOpts + :: Processor s + => (forall r. s r -> IO r) -- ^ server side handler + -> (forall r. s r -> Either SomeException r -> Header) + -> SocketServerOptions + -> (SocketServer -> IO ()) -- ^ computation to run while the server is up + -> IO () +withSocketServerOpts handler postProcess SocketServerOptions{..} action = + withProxy protocol $ \protProxy -> + withServerIO protProxy + (fmap show desiredPort) + (fromMaybe maxListenQueue maxQueuedConns) + handler + postProcess $ + \port -> action (SocketServer port protocol) + +-- | Run a Thrift server and some client computations against +-- it, using the given handler to process requests. +withServer + :: Processor s + => ProtocolId -- ^ protocol to use + -> Maybe ServiceName -- ^ desired port (if any) + -> Int -- ^ max. number of queued connections + -> (forall a . s a -> IO a) -- ^ server-side request handler + -> (forall a . s a -> Either SomeException a -> Header) + -> Thrift t () -- ^ client computation + -> IO () +withServer protocol mport maxQueuedConns hndl postProcess action = + withProxy protocol $ \proxy -> + withServerIO proxy mport maxQueuedConns hndl postProcess $ \port -> + withSocketChannel + (SocketConfig localhost (fromIntegral port) protocol) + action + +-- | Bring up a server that will handle requests with the given handler, +-- and run client computations against it in 'IO'. +withServerIO + :: forall c p. (Processor c, Protocol p) + => Proxy p + -> Maybe ServiceName -- ^ desired port (if any) + -> Int -- ^ max. number of queued connections + -> (forall r. c r -> IO r) -- ^ server handler + -> (forall r. c r -> Either SomeException r -> Header) + -> (Int -> IO ()) -- ^ client computation + -> IO () +withServerIO p mport maxQueuedConns handler postProcess client = do + counter <- newCounter + flip (runServer mport maxQueuedConns) + (\sock -> client . fromIntegral =<< socketPort sock) $ + \clientSock -> counter >>= \seqNum -> + handleClient seqNum counter Nothing clientSock + + where handleClient seqNum counter mincompleteMsg sock = + handleProtocolException p sock seqNum $ + handleClient' seqNum counter mincompleteMsg sock + handleClient' seqNum counter mincompleteMsg sock = do + minput <- try (threadWaitRecv sock recvBlockBytes) + case minput of + Left (e :: SomeException) -> do + throwProtocolException $ unwords + [ "an exception was raised while trying to read from" + , "the client socket: " ++ show e + ] + Right input + | BS.null input -> return () + | otherwise -> do + let input' = maybe input (<> input) mincompleteMsg + (mincomplete', seqNum') <- + processInput seqNum counter input' sock + handleClient seqNum' counter mincomplete' sock + + processInput seqNum counter input sock = + -- TODO: we'd perhaps like to know how much progress we make, to + -- distinguish bad input that we'll never be able to make sense + -- of, no matter how many more bytes we add to it, and + -- large commands that we receive in several chunks. + case parseAndLeftover (msgParser p) input of + -- 'input' is an incomplete command, we keep it around + -- to add more bytes to it before attempting to parse and + -- process it again + Left _ -> return (Just input, seqNum) + + -- 'input' contains at least a complete command, that we + -- process. If there's some leftover, we try and extract + -- a command from it as well, potentially doing this several + -- times, until either we're done or more input is needed to go + -- further. + Right ((msgSeqNum, Some cmd), leftover) -> do + (response, mexc, _headers) <- + processCommand p msgSeqNum handler postProcess cmd + seqNum' <- counter + case mexc of + Just (_exc, _blame) -> do + _ <- sendBS sock response + return (Nothing, seqNum') + Nothing -> do + let info = Map.lookup (reqName cmd) (methodsInfo (Proxy :: Proxy c)) + isOneway = maybe False methodIsOneway info + unless isOneway $ + void $ sendBS sock response + if BS.null leftover + then return (Nothing, seqNum') + else processInput seqNum' counter leftover sock + +sendException + :: Protocol p => Proxy p -> Socket -> SeqNum -> ApplicationException -> IO () +sendException proxy sock seqNum exc = + void $ sendBS sock protocolExcMsg + where protocolExcMsg = toStrict . toLazyByteString $ + genMsgBegin proxy "" 3 seqNum <> + buildStruct proxy exc <> + genMsgEnd proxy + +handleProtocolException + :: Protocol p + => Proxy p + -> Socket + -> SeqNum + -> IO () + -> IO () +handleProtocolException proxy sock seqNum m = m `catch` hndl + where hndl :: ApplicationException -> IO () + hndl exc = sendException proxy sock seqNum exc + +throwProtocolException :: String -> IO a +throwProtocolException err = throwIO (mkProtocolException err) + +mkProtocolException :: String -> ApplicationException +mkProtocolException err = ApplicationException (T.pack err) + ApplicationExceptionType_ProtocolError + +runServer + :: Maybe ServiceName -- ^ desired port (if any) + -> Int -- ^ max. number of queued connections + -> (Socket -> IO ()) -- ^ server computation + -> (Socket -> IO ()) -- ^ client computation + -> IO () +runServer mport maxQueuedConns server client = do + withSocketServer mport maxQueuedConns + (\servSock _sa -> client servSock) + (\sock _sa -> server sock) + +withSocketServer + :: Maybe ServiceName -- desired port (Nothing to bind any available port) + -> Int -- maximum number of queued connections + -> (Socket -> SockAddr -> IO ()) -- what to do when the server is up + -> (Socket -> SockAddr -> IO ()) -- what to do on a new client connection + -> IO () +withSocketServer mport maxQueuedConns onServerUp onNewClient = withSocketsDo $ do + addr <- resolveServer localhost mport + bracket (setupServerSock maxQueuedConns addr) teardownSock $ \sock -> + withAsync (acceptLoop sock) $ \_async -> + onServerUp sock (addrAddress addr) + + where acceptLoop sock = forever $ do + (clientSock, clientAddr) <- accept sock + forkFinally (onNewClient clientSock clientAddr) + (\_res -> mask_ $ teardownSock clientSock) + +setupServerSock :: Int -> AddrInfo -> IO Socket +setupServerSock maxQueuedConns addr = do + s <- openSocket addr + bind s (addrAddress addr) + listen s maxQueuedConns + return s + +resolveServer :: HostName -> Maybe ServiceName -> IO AddrInfo +resolveServer host mport = do + results <- getAddrInfo (Just hints) (Just host) mport + case results of + [] -> error "SocketServer.resolveServer: getAddrInfo returned an empty list" + (a:_) -> return a + + where hints = defaultHints { addrSocketType = Stream } + +#if !MIN_VERSION_network(3,1,2) +openSocket :: AddrInfo -> IO Socket +openSocket addr = + socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) +#endif diff --git a/Thrift/Codegen.hs b/Thrift/Codegen.hs new file mode 100644 --- /dev/null +++ b/Thrift/Codegen.hs @@ -0,0 +1,17 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Thrift.Codegen + ( module Thrift + ) where + +import Thrift.Channel as Thrift +import Thrift.Monad as Thrift +import Thrift.Protocol as Thrift +import Thrift.Protocol.JSON as Thrift +import Thrift.Protocol.JSON.Base64 as Thrift diff --git a/Thrift/CodegenTypesOnly.hs b/Thrift/CodegenTypesOnly.hs new file mode 100644 --- /dev/null +++ b/Thrift/CodegenTypesOnly.hs @@ -0,0 +1,24 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# OPTIONS_GHC -Wno-orphans #-} +module Thrift.CodegenTypesOnly + ( module Thrift + ) where + +import Thrift.Protocol as Thrift +import Thrift.Protocol.JSON as Thrift +import Thrift.Protocol.JSON.Base64 as Thrift + +import Thrift.HasFields as Thrift + +import Data.ByteString(ByteString) +import qualified Data.ByteString as ByteString +import Data.Default + +instance Default ByteString where def = ByteString.empty diff --git a/Thrift/HasFields.hs b/Thrift/HasFields.hs new file mode 100644 --- /dev/null +++ b/Thrift/HasFields.hs @@ -0,0 +1,21 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Thrift.HasFields (HasField(..)) where + +import GHC.TypeLits + +-- | HasField type family. Same as +-- GHC.Records.HasField, but custom so we can overlap it +class HasField (x :: Symbol) r a | x r -> a where + getField :: r -> a diff --git a/Thrift/Monad.hsc b/Thrift/Monad.hsc new file mode 100644 --- /dev/null +++ b/Thrift/Monad.hsc @@ -0,0 +1,125 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-star-is-type #-} +module Thrift.Monad + ( ThriftM + , ThriftEnv(..) + , RpcOptions(..), Priority(..) + , defaultRpcOptions, setRpcPriority, getRpcPriority + , runThrift, runThriftWith, withOptions, withModifiedOptions + , catchThrift, bracketThrift, bracketThrift_, tryThrift + , Counter, newCounter + , type (<:), Super + ) where + +import Control.Exception +import Control.Monad.Trans.Reader +import Data.Int +import Data.IORef +import Data.Proxy +import GHC.TypeLits +import Thrift.Protocol.RpcOptions.Types +import Util.Reader + +-- Thrift Monad ---------------------------------------------------------------- + +type ThriftM p c s = ReaderT (ThriftEnv p c s) IO + +data ThriftEnv p c s = ThriftEnv + { thriftProxy :: Proxy p + , thriftChannel :: c s + , thriftRpcOpts :: RpcOptions + , thriftCounter :: Counter + } + +defaultRpcOptions :: RpcOptions +defaultRpcOptions = RpcOptions + { rpc_timeout = 0 + , rpc_priority = Nothing + , rpc_chunkTimeout = 0 + , rpc_queueTimeout = 0 + , rpc_headers = Nothing + } + +getRpcPriority :: RpcOptions -> Maybe Priority +getRpcPriority RpcOptions{..} = rpc_priority + +setRpcPriority :: RpcOptions -> Priority -> RpcOptions +setRpcPriority opts@RpcOptions{..} prio = + case rpc_priority of + Just _ -> opts + Nothing -> opts{rpc_priority = Just prio} + +runThrift :: ThriftM p c s a -> c s -> IO a +runThrift action channel = runThriftWith action channel defaultRpcOptions + +runThriftWith :: ThriftM p c s a -> c s -> RpcOptions -> IO a +runThriftWith action channel opts = + newCounter >>= runReaderT action . ThriftEnv Proxy channel opts + +withOptions :: RpcOptions -> ThriftM p c s a -> ThriftM p c s a +withOptions opts = withReaderT (\env -> env { thriftRpcOpts = opts }) + +withModifiedOptions + :: (RpcOptions -> RpcOptions) -> ThriftM p c s a -> ThriftM p c s a +withModifiedOptions f = withReaderT $ + \env@ThriftEnv{..} -> env { thriftRpcOpts = f thriftRpcOpts } + +catchThrift + :: Exception e => ThriftM p c s a -> (e -> ThriftM p c s a) -> ThriftM p c s a +catchThrift = catchR + +bracketThrift + :: ThriftM p c s a -- ^ before + -> (a -> ThriftM p c s b) -- ^ after + -> (a -> ThriftM p c s d) -- ^ computation + -> ThriftM p c s d +bracketThrift = bracketR + +bracketThrift_ + :: ThriftM p c s a -- ^ before + -> ThriftM p c s b -- ^ after + -> ThriftM p c s d -- ^ computation + -> ThriftM p c s d +bracketThrift_ = bracketR_ + +tryThrift :: Exception e => ThriftM p c s a -> ThriftM p c s (Either e a) +tryThrift m = (Right <$> m) `catchThrift` (pure . Left) + +-- Seqeuence Counters ---------------------------------------------------------- + +type Counter = IO Int32 + +newCounter :: IO Counter +newCounter = do + ref <- newIORef 0 + return $ do + count <- readIORef ref + writeIORef ref (count + 1) + return count + +-- Subtyping of Services ------------------------------------------------------- + + +-- | The subtyping constraint +class a <: b + +-- | Supertype Relation +type family Super (s :: *) :: * + +type family IsSuper a b (n :: Nat) :: Bool where + IsSuper a b 0 = 'False + IsSuper a a n = 'True + IsSuper a b n = IsSuper (Super a) b (n - 1) + +type MaxChainSize = 100 + +instance (IsSuper a b MaxChainSize ~ 'True) => a <: b diff --git a/Thrift/Processor.hs b/Thrift/Processor.hs new file mode 100644 --- /dev/null +++ b/Thrift/Processor.hs @@ -0,0 +1,138 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE CPP #-} +module Thrift.Processor + ( Processor(..) + , Blame(..) + , Header + , process + , processCommand + , msgParser + , Some(..) + , MethodInfo(..) + ) where + +import Control.Exception +import Thrift.Binary.Parser +import Data.ByteString +import Data.ByteString.Builder +#if __GLASGOW_HASKELL__ < 902 +import Data.ByteString.Lazy (toStrict) +#endif +import Data.Int +import Data.Some +import Data.Map (Map) +#if __GLASGOW_HASKELL == 804 +import Data.Monoid ((<>)) +#endif +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as Text + +import Thrift.Channel (Header) +import Thrift.Protocol +import Thrift.Protocol.ApplicationException.Types +import Thrift.Monad (Priority(..)) + +data Blame = ClientError | ServerError + deriving (Eq,Ord,Enum,Bounded,Read,Show) + +data MethodInfo = MethodInfo + { methodPriority :: Priority + , methodIsOneway :: Bool + } + +-- | Class of types that can handle parsing + running thrift requests +class Processor s where + -- | Returns the name for a particular function + reqName :: s a -> Text + -- | Parses the structure based on "text" name into a command + reqParser :: Protocol p => Proxy p -> Text -> Parser (Some s) + -- | Generate the serialized response for the returned structure as well as + -- exception information + respWriter + :: Protocol p + => Proxy p + -> Int32 + -> s a + -> Either SomeException a + -> (Builder, Maybe (SomeException, Blame)) + -- | Static information about a method + methodsInfo :: Proxy s -> Map Text MethodInfo + methodsInfo = const mempty + +-- | `process` should be called once for each received request +process :: (Processor s, Protocol p) + => Proxy p -- ^ The server's protocol to use + -> SeqNum -- ^ Sequence number + -> (forall r . s r -> IO r) + -- ^ Handler for user-code + -> (forall r . s r -> Either SomeException r -> Header) + -> ByteString -- ^ Input bytes off the wire + -> IO (ByteString, Maybe (SomeException, Blame), Header) + -- ^ Output bytes to put on the wire as well as the exception + -- information for the response +process proxy seqNum handler postProcess input = do + (response, exc, headers) <- case parse (msgParser proxy) input of + Left err -> do + -- Parsing failed, so the protocol is broken + let ex = ApplicationException (Text.pack err) + ApplicationExceptionType_ProtocolError + return + ( toStrict $ toLazyByteString $ + genMsgBegin proxy "" 3 seqNum + <> buildStruct proxy ex + <> genMsgEnd proxy + , Just (toException ex, ClientError) + , [] ) + Right (msgSeqNum, Some cmd) -> processCommand proxy msgSeqNum handler postProcess cmd + return (response, exc, headers) + +processCommand + :: (Processor s, Protocol p) + => Proxy p + -> SeqNum + -> (forall r . s r -> IO r) -- ^ Handler for user-code + -> (forall r . s r -> Either SomeException r -> Header) + -> s r -- ^ input command + -> IO (ByteString, Maybe (SomeException, Blame), Header) +processCommand proxy seqNum handler postProcess cmd = + -- in case we cannot serialize the uncaught exception itself (e.g. due to + -- another exception being thrown when serializing it), we fallback to an + -- predefined one, assuming @respWriter@ and @postProcess@ never fail on + -- it. + handle (\(_ :: SomeException) -> buildResp $ Left nonserializableError) $ + -- catch all uncaught exception from handler to prevent it from being leaked. + handle (\e -> buildResp $ Left e) $ + buildResp . Right =<< handler cmd + where + nonserializableError = toException $ ApplicationException + "processCommand: uncaught non-serializable error" + ApplicationExceptionType_InternalError + buildResp res = + -- force evaluation of the response + evaluate $ bs `seq` exc `seq` headers `seq` (bs, exc, headers) + where + (builder, exc) = respWriter proxy seqNum cmd res + headers = postProcess cmd res + bs = toStrict $ toLazyByteString builder + +msgParser + :: (Processor s, Protocol p) + => Proxy p -> Parser (SeqNum, Some s) +msgParser proxy = do + MsgBegin funName msgTy msgSeqNum <- parseMsgBegin proxy + command <- case msgTy of + 1 -> reqParser proxy funName + 2 -> fail $ Text.unpack $ funName <> " expected call but got reply" + 3 -> fail $ Text.unpack $ funName <> " expected call but got exception" + 4 -> reqParser proxy funName + _ -> fail $ Text.unpack $ funName <> ": invalid message type" + parseMsgEnd proxy + return (msgSeqNum, command) diff --git a/Thrift/Protocol.hs b/Thrift/Protocol.hs new file mode 100644 --- /dev/null +++ b/Thrift/Protocol.hs @@ -0,0 +1,253 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE ConstraintKinds, CPP #-} +module Thrift.Protocol + ( ThriftSerializable, serializeGen, deserializeGen + , ThriftStruct(..), ProtocolException(..) + , Protocol(..), parseStop, parseEnum, parseEnumNoUnknown + , FieldId, Length, Type, MsgType, SeqNum + , FieldBegin(..), MsgBegin(..) + , genByte, genI16, genI32, genI64, genBool + , ThriftEnum(..) + , unknownThriftEnumErrorMsg + ) where + +import Control.Exception +import Data.Aeson hiding (Bool, String) +import Thrift.Binary.Parser +import Data.ByteString (ByteString) +import Data.ByteString.Builder +import Data.ByteString.Builder.Prim +import Data.HashMap.Strict as HashMap +import Data.Int +import Data.Proxy +import Data.Text (Text) +import Data.Text.Encoding +import Data.Typeable +import Data.Word +import qualified Data.ByteString.Lazy as LBS + +#if __GLASGOW_HASKELL__ == 806 +import Prelude hiding (fail) +import Control.Monad.Fail (fail) +#endif + + +-- Constraint Kind that every Thrift generated datatype must satisfy +type ThriftSerializable a = (ToJSON a, ThriftStruct a) + +class ThriftStruct a where + buildStruct :: Protocol p => Proxy p -> a -> Builder + parseStruct :: Protocol p => Proxy p -> Parser a + +class ThriftEnum a where + toThriftEnum :: Int -> a + fromThriftEnum :: a -> Int + allThriftEnumValues :: [a] + toThriftEnumEither :: Int -> Either String a + +instance ThriftEnum Bool where + toThriftEnum n | n == 0 = False + | n == 1 = True + | otherwise = errorWithoutStackTrace + "Thrift.Protocol.ThriftEnum.Bool.toThriftEnum: bad argument" + fromThriftEnum False = 0 + fromThriftEnum True = 1 + allThriftEnumValues = [False, True] + toThriftEnumEither n | n == 0 = Right False + | n == 1 = Right True + | otherwise = Left "Thrift.Protocol.ThriftEnum.Bool.toThriftEnumEither: bad argument" + +{-# INLINE serializeGen #-} +serializeGen + :: (Protocol p, ThriftStruct a) + => Proxy p + -> a + -> ByteString +serializeGen proxy = LBS.toStrict . toLazyByteString . buildStruct proxy + +{-# INLINE deserializeGen #-} +deserializeGen + :: (Protocol p, ThriftStruct a) + => Proxy p + -> ByteString + -> Either String a +deserializeGen proxy input = parse (parseStruct proxy) input + +newtype ProtocolException = ProtocolException String + deriving (Show, Eq) +instance Exception ProtocolException + +-- Binary Protocol type class -------------------------------------------------- + +type FieldId = Int16 +type Length = Word32 +type Type = Word8 +type IdMap = HashMap Text FieldId + +type MsgType = Word8 +type SeqNum = Int32 + +data FieldBegin + = FieldBegin {-# UNPACK #-} !Type {-# UNPACK #-} !FieldId !Bool + | FieldEnd + +data MsgBegin + = MsgBegin !Text {-# UNPACK #-} !MsgType {-# UNPACK #-} !SeqNum + deriving (Show, Eq) + +class Protocol p where + -- Generators for Types + getByteType :: Proxy p -> Type + getI16Type :: Proxy p -> Type + getI32Type :: Proxy p -> Type + getI64Type :: Proxy p -> Type + getFloatType :: Proxy p -> Type + getDoubleType :: Proxy p -> Type + getBoolType :: Proxy p -> Type + getStringType :: Proxy p -> Type + getListType :: Proxy p -> Type + getSetType :: Proxy p -> Type + getMapType :: Proxy p -> Type + getStructType :: Proxy p -> Type + + -- Generators for tokens + genMsgBegin :: Proxy p -> Text -> MsgType -> SeqNum -> Builder + + genStruct :: Proxy p -> [Builder] -> Builder + + genField + :: Proxy p -> Text -> Type -> FieldId -> FieldId -> Builder -> Builder + genFieldPrim + :: Proxy p -> Text -> Type -> FieldId -> FieldId + -> BoundedPrim a -> a -> Builder + + -- Only Compact protocol needs a custom implementation for this + genFieldBool + :: Proxy p -> Text -> FieldId -> FieldId -> Bool -> Builder + genFieldBool proxy name fid lastId = + genFieldPrim proxy name (getBoolType proxy) fid lastId (genBoolPrim proxy) + + genList :: Proxy p -> Type -> (a -> Builder) -> [a] -> Builder + genListPrim :: Proxy p -> Type -> BoundedPrim a -> [a] -> Builder + + genMap :: Proxy p -> Type -> Type -> Bool + -> (k -> Builder) -> (v -> Builder) + -> [(k, v)] -> Builder + genMapPrim :: Proxy p -> Type -> Type -> Bool + -> BoundedPrim k -> BoundedPrim v + -> [(k, v)] -> Builder + + genMsgEnd :: Proxy p -> Builder + genMsgEnd _ = mempty + + -- Primitive Generators (for base types) + genBytePrim :: Proxy p -> BoundedPrim Int8 + genI16Prim :: Proxy p -> BoundedPrim Int16 + genI32Prim :: Proxy p -> BoundedPrim Int32 + genI64Prim :: Proxy p -> BoundedPrim Int64 + genBoolPrim :: Proxy p -> BoundedPrim Bool + + + -- Generators for string types (implement 1) + genText :: Proxy p -> Text -> Builder + genText p = genByteString p . encodeUtf8 + genByteString :: Proxy p -> ByteString -> Builder + genByteString p = genText p . decodeUtf8 + + -- Generator for binary + genBytes :: Proxy p -> ByteString -> Builder + genBytes = genByteString + + -- Generators for other base types + genFloat :: Proxy p -> Float -> Builder + genDouble :: Proxy p -> Double -> Builder + + -- Parsers for tokens + parseMsgBegin :: Proxy p -> Parser MsgBegin + parseMsgEnd :: Proxy p -> Parser () + parseMsgEnd _ = return () + + parseFieldBegin :: Proxy p -> FieldId -> IdMap -> Parser FieldBegin + parseList :: Proxy p -> Parser a -> Parser (Int,[a]) + parseMap :: Proxy p -> Parser k -> Parser v -> Bool -> Parser [(k, v)] + + -- Parser for base types + parseByte :: Proxy p -> Parser Int8 + parseI16 :: Proxy p -> Parser Int16 + parseI32 :: Proxy p -> Parser Int32 + parseI64 :: Proxy p -> Parser Int64 + parseFloat :: Proxy p -> Parser Float + parseDouble :: Proxy p -> Parser Double + parseBool :: Proxy p -> Parser Bool + parseBoolF :: Proxy p -> Bool -> Parser Bool + + -- Parsers for strings + parseText :: Proxy p -> Parser Text + parseText p = decodeUtf8 <$> parseByteString p + parseByteString :: Proxy p -> Parser ByteString + parseByteString p = encodeUtf8 <$> parseText p + + -- Parser for binary + parseBytes :: Proxy p -> Parser ByteString + parseBytes = parseByteString + + parseSkip :: Proxy p -> Type -> Maybe Bool -> Parser () + +genByte :: Protocol p => Proxy p -> Int8 -> Builder +genByte p = primBounded (genBytePrim p) + +genI16 :: Protocol p => Proxy p -> Int16 -> Builder +genI16 p = primBounded (genI16Prim p) + +genI32 :: Protocol p => Proxy p -> Int32 -> Builder +genI32 p = primBounded (genI32Prim p) + +genI64 :: Protocol p => Proxy p -> Int64 -> Builder +genI64 p = primBounded (genI64Prim p) + +genBool :: Protocol p => Proxy p -> Bool -> Builder +genBool p = primBounded (genBoolPrim p) + +parseStop :: Protocol p => Proxy p -> Parser () +parseStop token = do + end <- parseFieldBegin token 0 HashMap.empty + case end of + FieldBegin{} -> fail "parseStop: expected end of struct" + FieldEnd -> return () + +parseEnum + :: (Protocol p, ThriftEnum a) + => Proxy p + -> String + -> Parser a +parseEnum proxy _ = do + n <- parseI32 proxy + return $ toThriftEnum (fromIntegral n) + +parseEnumNoUnknown + :: (Protocol p, ThriftEnum a) + => Proxy p + -> String + -> Parser a +parseEnumNoUnknown proxy name = do + n <- parseI32 proxy + case toThriftEnumEither (fromIntegral n) of + Left _ -> fail $ + "parseEnum: not a valid identifier for thrift enum '" ++ name ++ "': " + ++ show n + Right enum -> return enum + +unknownThriftEnumErrorMsg :: (Typeable a, Show a) => a -> String +unknownThriftEnumErrorMsg x = "Unknown value " + ++ show x + ++ " for enum " + ++ show (tyConModule $ typeRepTyCon $ typeOf x) + ++ "." + ++ show (typeOf x) diff --git a/Thrift/Protocol/Binary.hs b/Thrift/Protocol/Binary.hs new file mode 100644 --- /dev/null +++ b/Thrift/Protocol/Binary.hs @@ -0,0 +1,213 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE CPP #-} +module Thrift.Protocol.Binary + ( serializeBinary, deserializeBinary + , Binary + ) where + +import Control.Monad +import Thrift.Binary.Parser +import Data.Bits +import Data.ByteString (ByteString) +import Data.ByteString.Builder +import Data.ByteString.Builder.Prim as Prim +import Data.List +import Data.Proxy +import Data.Text.Encoding +import Data.Word +import qualified Thrift.Binary.Parser as P +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as B +import qualified Data.HashMap.Strict as HashMap + +import Thrift.Protocol +import Thrift.Protocol.Binary.Internal + +data Binary + +serializeBinary :: ThriftStruct a => a -> ByteString +serializeBinary = serializeGen (Proxy :: Proxy Binary) + +deserializeBinary :: ThriftStruct a => ByteString -> Either String a +deserializeBinary = deserializeGen (Proxy :: Proxy Binary) + +-- Type Macros ----------------------------------------------------------------- + +#define TSTOP 0 +#define TBOOL 2 +#define TBYTE 3 +#define TDOUBLE 4 +#define TI16 6 +#define TI32 8 +#define TI64 10 +#define TSTRING 11 +#define TSTRUCT 12 +#define TMAP 13 +#define TSET 14 +#define TLIST 15 +#define TFLOAT 19 + +version1 :: Word32 +version1 = 0x80010000 + +versionMask :: Word32 +versionMask = 0xFFFF0000 + +-- BinaryProtocol instance ----------------------------------------------------- + +instance Protocol Binary where + -- Generators for Types + getByteType _ = TBYTE + getI16Type _ = TI16 + getI32Type _ = TI32 + getI64Type _ = TI64 + getFloatType _ = TFLOAT + getDoubleType _ = TDOUBLE + getBoolType _ = TBOOL + getStringType _ = TSTRING + getListType _ = TLIST + getSetType _ = TSET + getMapType _ = TMAP + getStructType _ = TSTRUCT + + -- Generators for tokens + genMsgBegin proxy name msgType seqNum = + B.word32BE (version1 .|. fromIntegral msgType) <> + genText proxy name <> + B.int32BE seqNum + + genStruct _ fields = mconcat fields <> B.word8 TSTOP + + genField _ _ ty fid _ val = B.word8 ty <> B.int16BE fid <> val + genFieldPrim _ _ ty fid _ prim val = primBounded + (liftFixedToBounded (Prim.word8 >*< Prim.int16BE) >*< prim) + ((ty, fid), val) + + genList _ ty build elems = + genListBegin ty elems <> mconcat (map build elems) + + genListPrim _ ty build elems = + genListBegin ty elems <> primMapListBounded build elems + + genMap _ kt vt _ kbuild vbuild elems = + genMapBegin kt vt elems <> mconcat (map build elems) + where + build (k, v) = kbuild k <> vbuild v + + genMapPrim _ kt vt _ kbuild vbuild elems = + genMapBegin kt vt elems <> primMapListBounded build elems + where + build = kbuild >*< vbuild + + -- Generators for base types + genBytePrim _ = liftFixedToBounded Prim.int8 + genI16Prim _ = liftFixedToBounded Prim.int16BE + genI32Prim _ = liftFixedToBounded Prim.int32BE + genI64Prim _ = liftFixedToBounded Prim.int64BE + genFloat _ = B.floatBE + genDouble _ = B.doubleBE + genBoolPrim _ = liftFixedToBounded $ + (\b -> if b then 1 else 0) >$< Prim.word8 + genByteString _ s = B.int32BE len <> byteString s + where + len = fromIntegral $ BS.length s + + -- Parsers for tokens + parseMsgBegin proxy = do + versionAndType <- getWord32be + let + version = versionAndType .&. versionMask + msgType = fromIntegral (versionAndType .&. 0x000000FF) + when (version /= version1) $ fail "parseMsgBegin: invalid version" + name <- parseText proxy + seqNum <- getInt32be + return $ MsgBegin name msgType seqNum + + parseFieldBegin _ _ _ = do + ty <- anyWord8 + if ty == TSTOP + then pure FieldEnd + else FieldBegin ty <$> getInt16be <*> pure False + + parseList _ p = do + _ <- anyWord8 + len <- getInt32be + ps <- replicateM (fromIntegral len) p + return (fromIntegral len, ps) + + parseMap _ pk pv _ = do + _ <- anyWord8 + _ <- anyWord8 + len <- getInt32be + replicateM (fromIntegral len) $ (,) <$> pk <*> pv + + -- Parser for base types + parseByte _ = fromIntegral <$> P.anyWord8 + parseI16 _ = getInt16be + parseI32 _ = getInt32be + parseI64 _ = getInt64be + parseFloat _ = binaryFloat + parseDouble _ = binaryDouble + parseBool _ = binaryBool + parseBoolF _ _ = binaryBool + parseByteString _ = getBuffer getInt32be BS.copy + parseText _ = getBuffer getInt32be decodeUtf8 + + parseSkip _ TBYTE _ = skipN 1 + parseSkip _ TI16 _ = skipN 2 + parseSkip _ TI32 _ = skipN 4 + parseSkip _ TI64 _ = skipN 8 + parseSkip _ TFLOAT _ = skipN 4 + parseSkip _ TDOUBLE _ = skipN 8 + parseSkip _ TBOOL _ = skipN 1 + parseSkip _ TSTRING _ = getInt32be >>= skipN . fromIntegral + parseSkip proxy TLIST _ = skipList proxy + parseSkip proxy TSET _ = skipList proxy + parseSkip proxy TMAP _ = do + k <- anyWord8 + v <- anyWord8 + len <- getInt32be + replicateM_ (fromIntegral len) $ + (,) <$> parseSkip proxy k Nothing <*> parseSkip proxy v Nothing + parseSkip proxy TSTRUCT _ = do + fbegin <- parseFieldBegin proxy 0 HashMap.empty + case fbegin of + FieldBegin ty _ _ -> parseSkip proxy ty Nothing *> + parseSkip proxy TSTRUCT Nothing + FieldEnd -> pure () + parseSkip _ n _ = fail $ "unrecognized type code: " ++ show n + +skipList :: Proxy Binary -> Parser () +skipList proxy = do + ty <- anyWord8 + len <- getInt32be + replicateM_ (fromIntegral len) (parseSkip proxy ty Nothing) + +genListBegin :: Type -> [a] -> Builder +genListBegin ty elems = + primFixed (Prim.word8 >*< Prim.word32BE) (ty, len) + where len = genericLength elems + +genMapBegin :: Type -> Type -> [a] -> Builder +genMapBegin kt vt elems = + primFixed + (Prim.word8 >*< Prim.word8 >*< Prim.word32BE) + (kt, (vt, len)) + where + len = genericLength elems + +{-# INLINE binaryBool #-} +binaryBool :: Parser Bool +binaryBool = do + byte <- P.anyWord8 + case byte of + 0 -> pure False + 1 -> pure True + n -> fail $ "invalid boolean value: " ++ show n diff --git a/Thrift/Protocol/Binary/Internal.hs b/Thrift/Protocol/Binary/Internal.hs new file mode 100644 --- /dev/null +++ b/Thrift/Protocol/Binary/Internal.hs @@ -0,0 +1,51 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE CPP #-} +module Thrift.Protocol.Binary.Internal + ( binaryFloat, binaryDouble, getBuffer + ) where + +#if __GLASGOW_HASKELL__ == 804 +import Thrift.Binary.Parser (getWord32be) +#endif +import Thrift.Binary.Parser as P +import Data.ByteString (ByteString) +import Foreign.Marshal.Alloc +import Foreign.Storable as F +import Foreign.Ptr +import System.IO.Unsafe + +{-# INLINE toFloat #-} +toFloat + :: (Floating f, Storable f, Storable a) + => a + -> f +toFloat a = + unsafeDupablePerformIO $ alloca $ \ptr -> + poke ptr a >> F.peek (castPtr ptr) + +{-# INLINE binaryFloat #-} +binaryFloat :: Parser Float +binaryFloat = toFloat <$> getWord32be + +{-# INLINE binaryDouble #-} +binaryDouble :: Parser Double +binaryDouble = toFloat <$> getWord64be + +{-# INLINE getBuffer #-} +-- | Parse a ByteString given a length parser and a copy function. +-- Note: The copy function *must* copy the input, otherwise this is unsafe +-- because the result is a slice of the input which may be a memory buffer that +-- is owned by C++. We also want to eliminate references to the input so that it +-- can get GC'd +getBuffer :: Integral len => Parser len -> (ByteString -> a) -> Parser a +getBuffer getLength copy = do + len <- getLength + buf <- P.getByteString $ fromIntegral len + return $! copy buf diff --git a/Thrift/Protocol/Compact.hs b/Thrift/Protocol/Compact.hs new file mode 100644 --- /dev/null +++ b/Thrift/Protocol/Compact.hs @@ -0,0 +1,389 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +module Thrift.Protocol.Compact + ( serializeCompact + , deserializeCompact + , Compact + ) where + +import Control.Monad +import Thrift.Binary.Parser as P +import Data.Bits +import Data.ByteString (ByteString) +import Data.ByteString.Builder as B +import Data.ByteString.Builder.Prim as Prim +import Data.Int +import Data.List +import Data.Proxy +import Data.Text.Encoding +import Data.Word +import GHC.Base hiding (build, Type) +import GHC.Word +import qualified Data.ByteString as BS +import qualified Data.HashMap.Strict as HashMap + +import Thrift.Protocol +import Thrift.Protocol.Binary.Internal + +data Compact + +serializeCompact :: ThriftStruct a => a -> ByteString +serializeCompact = serializeGen (Proxy :: Proxy Compact) + +deserializeCompact :: ThriftStruct a => ByteString -> Either String a +deserializeCompact = deserializeGen (Proxy :: Proxy Compact) + +-- Macros for ThriftTypes ------------------------------------------------------ + +#define TSTOP 0x00 +#define TTRUE 0x01 +#define TFALSE 0x02 +#define TBYTE 0x03 +#define TI16 0x04 +#define TI32 0x05 +#define TI64 0x06 +#define TDOUBLE 0x07 +#define TSTRING 0x08 +#define TLIST 0x09 +#define TSET 0x0A +#define TMAP 0x0B +#define TSTRUCT 0x0C +#define TFLOAT 0x0D + +protocolVersion :: Word8 +protocolVersion = 0x02 + +protocolID :: Word8 +protocolID = 0x82 + +typeMask :: Word8 +typeMask = 0xE0 + +versionMask :: Word8 +versionMask = 0x1F + +shiftAmt :: Int +shiftAmt = 5 + +-- BinaryWriter instance ------------------------------------------------------- + +instance Protocol Compact where + -- Generators for Types + getByteType _ = TBYTE + getI16Type _ = TI16 + getI32Type _ = TI32 + getI64Type _ = TI64 + getFloatType _ = TFLOAT + getDoubleType _ = TDOUBLE + getBoolType _ = TTRUE + getStringType _ = TSTRING + getListType _ = TLIST + getSetType _ = TSET + getMapType _ = TMAP + getStructType _ = TSTRUCT + + -- Generators for tokens + genMsgBegin proxy name msgType seqNum = + primBounded + (liftFixedToBounded Prim.word8 >*< + liftFixedToBounded Prim.word8 >*< + compactI32) + (protocolID, + (protocolVersion .|. ((msgType `shiftL` shiftAmt) .&. typeMask), + seqNum)) <> + genText proxy name + + genStruct _ fields = mconcat fields <> B.word8 TSTOP + + -- NOTE: This will not work correctly for generating boolean fields. Boolean + -- fields MUST be generated using genFieldPrim + genField _ _ ty fid lastId val = + primBounded (compactFieldBegin ty) (fid, lastId) <> val + + genFieldPrim _ _ ty fid lastId prim val = + primBounded (compactFieldBegin ty >*< prim) ((fid, lastId), val) + + genFieldBool _ _ fid lastId val = + primBounded (compactFieldBegin ty) (fid, lastId) + where + ty = if val then TTRUE else TFALSE + + genList _ ty build elems = + genListBegin ty elems <> + mconcat (map build elems) + + genListPrim _ ty bounded elems = + genListBegin ty elems <> + primMapListBounded bounded elems + + genMap _ kt vt _ kbuild vbuild elems = + genMapBegin kt vt elems <> + mconcat (map (\(k, v) -> kbuild k <> vbuild v) elems) + + genMapPrim _ kt vt _ kbuild vbuild elems = + genMapBegin kt vt elems <> + primMapListBounded (kbuild >*< vbuild) elems + + -- Generators for base types + genBytePrim _ = liftFixedToBounded Prim.int8 + genI16Prim _ = compactI16 + genI32Prim _ = compactI32 + genI64Prim _ = compactI64 + genFloat _ = B.floatBE + genDouble _ = B.doubleBE + genBoolPrim _ = liftFixedToBounded $ getVal >$< Prim.word8 + where getVal b = if b then TTRUE else TFALSE + + genByteString _ s = + primBounded buildVarint (W# (int2Word# len)) <> byteString s + where + !(I# len) = BS.length s + + -- Parsers for tokens + parseMsgBegin proxy = do + pid <- P.anyWord8 + when (pid /= protocolID) $ fail "parseMsgBegin: invalid protocol id" + versionAndType <- P.anyWord8 + let + version = versionAndType .&. versionMask + msgType = (versionAndType .&. typeMask) `shiftR` shiftAmt + when (version /= protocolVersion) $ + fail "parseMsgBegin: invalid protocol version" + seqNum <- parseCompactI32 + name <- parseText proxy + return $ MsgBegin name msgType seqNum + + parseFieldBegin _ lastId _ = do + byte <- anyWord8 + let rawType = byte .&. 0x0F + if rawType == TSTOP + then pure FieldEnd + else do + -- Boolean Value is encoded in the type + let (!ty, !bool) = + case rawType of + 0x01 -> (TTRUE, True) + 0x02 -> (TTRUE, False) + mask -> (mask, False) + -- Field Id depends on previous field Id + fid <- case byte `shiftR` 4 of + 0x00 -> parseCompactI16 + offs -> pure $ fromIntegral offs + lastId + return $ FieldBegin ty fid bool + + parseList _ p = do + byte <- anyWord8 + let _ty = byte .&. 0x0F + len <- case byte `shiftR` 4 of + 0x0F -> parseVarint + size -> pure $ fromIntegral size + ps <- replicateM (fromIntegral len) p + return (fromIntegral len, ps) + + parseMap _ pk pv _ = do + len <- parseVarint + if len == 0 + then pure [] + else do + byte <- anyWord8 + let _ktype = byte `shiftR` 4 + _vtype = byte .&. 0x0F + replicateM (fromIntegral len) $ (,) <$> pk <*> pv + + -- Parser for base types + parseByte _ = fromIntegral <$> anyWord8 + parseI16 _ = parseCompactI16 + parseI32 _ = parseCompactI32 + parseI64 _ = parseCompactI64 + parseFloat _ = binaryFloat + parseDouble _ = binaryDouble + parseBool _ = do + byte <- P.anyWord8 + case byte of + TTRUE -> pure True + TFALSE -> pure False + n -> fail $ "invalid boolean value: " ++ show n + + parseBoolF _ = pure + parseByteString _ = getBuffer parseVarint BS.copy + parseText _ = getBuffer parseVarint decodeUtf8 + + parseSkip _ TTRUE Nothing = P.skipN 1 + parseSkip _ TFALSE Nothing = P.skipN 1 + parseSkip _ TTRUE Just{} = pure () + parseSkip _ TFALSE Just{} = pure () + parseSkip _ TBYTE _ = P.skipN 1 + parseSkip _ TI16 _ = void parseCompactI16 + parseSkip _ TI32 _ = void parseCompactI32 + parseSkip _ TI64 _ = void parseCompactI64 + parseSkip _ TDOUBLE _ = P.skipN 8 + parseSkip _ TSTRING _ = + void $ parseVarint >>= P.skipN . fromIntegral + parseSkip proxy TLIST _ = do + byte <- anyWord8 + let ty = byte .&. 0x0F + len <- case byte `shiftR` 4 of + 0x0F -> parseVarint + size -> pure $ fromIntegral size + void $ replicateM (fromIntegral len) (parseSkip proxy ty Nothing) + + parseSkip proxy TSET _ = parseSkip proxy TLIST Nothing + parseSkip proxy TMAP _ = do + len <- parseVarint + if len == 0 + then pure () + else do + byte <- anyWord8 + let ktype = byte `shiftR` 4 + vtype = byte .&. 0x0F + void $ replicateM (fromIntegral len) $ + (,) <$> parseSkip proxy ktype Nothing <*> parseSkip proxy vtype Nothing + + parseSkip proxy TSTRUCT _ = do + -- The last id deosn't matter since we do not need to correctly parse field + -- ids. We don't recognize this field, therefore it will be discarded anyway + fieldBegin <- parseFieldBegin proxy 0 HashMap.empty + case fieldBegin of + FieldBegin ty _ bool -> + parseSkip proxy ty (Just bool) *> parseSkip proxy TSTRUCT Nothing + FieldEnd -> pure () + parseSkip _ n _ = fail $ "unrecognized type code: " ++ show n + +-- Helpers --------------------------------------------------------------------- + +{-# INLINE compactFieldBegin #-} +compactFieldBegin :: Type -> BoundedPrim (FieldId, FieldId) +compactFieldBegin ty = condB + (\(fid, lastId) -> fid > lastId && fid - lastId < 16) + ((\(fid, lastId) -> fromIntegral (fid - lastId) `shiftL` 4 .|. ty) >$< + liftFixedToBounded Prim.word8) + ((\(fid, _) -> (ty, fid)) >$< + liftFixedToBounded Prim.word8 >*< compactI16) + +compactI16 :: BoundedPrim Int16 +compactI16 = i16ToZigZag >$< buildVarint2 + +compactI32 :: BoundedPrim Int32 +compactI32 = i32ToZigZag >$< buildVarint4 + +compactI64 :: BoundedPrim Int64 +compactI64 = i64ToZigZag >$< buildVarint + +parseCompactI16 :: Parser Int16 +parseCompactI16 = zigZagToInt <$> parseVarint + +parseCompactI32 :: Parser Int32 +parseCompactI32 = zigZagToInt <$> parseVarint + +parseCompactI64 :: Parser Int64 +parseCompactI64 = zigZagToInt <$> parseVarint + +genListBegin :: Type -> [a] -> Builder +genListBegin ty elems = (`primBounded` len) $ + condB (< 15) + ((\l -> (fromIntegral l `shiftL` 4) .|. ty) >$< + liftFixedToBounded Prim.word8) + ((\l -> (0xF0 .|. ty, fromIntegral l)) >$< + (liftFixedToBounded Prim.word8 >*< buildVarint)) + where len = length elems + +genMapBegin :: Type -> Type -> [a] -> Builder +genMapBegin kt vt elems + | null elems = B.word8 0x00 + | otherwise = (`primBounded` len) $ + (\l -> (l, kt `shiftL` 4 .|. vt)) >$< + (buildVarint >*< liftFixedToBounded Prim.word8) + where len = genericLength elems + +-- Variable Length Encoded Integers -------------------------------------------- + +-- Signed numbers must be converted to "Zig Zag" format before they can be +-- serialized in the Varint format + +{-# INLINE iToZigZag #-} +iToZigZag :: (Bits i, Integral i) => Int -> i -> Word +iToZigZag s n = fromIntegral $ (n `shiftL` 1) `xor` (n `shiftR` s) + +{-# INLINE i16ToZigZag #-} +i16ToZigZag :: Int16 -> Word +i16ToZigZag n = 0xFFFF .&. iToZigZag 15 n + +{-# INLINE i32ToZigZag #-} +i32ToZigZag :: Int32 -> Word +i32ToZigZag n = 0xFFFFFFFF .&. iToZigZag 31 n + +{-# INLINE i64ToZigZag #-} +i64ToZigZag :: Int64 -> Word +i64ToZigZag = iToZigZag 63 + +-- This is janky, but BoundedPrim requires the size of the value it is building +-- to be bounded. Varints *are* bounded, but the output size depends on their +-- value. A 64-bit value can take up to 80 bits to encode, because each 7-bits +-- in the input map to 8 bits in the output. We therefore need 10 builders, each +-- one decreasing in potential maximum size. +buildVarint :: BoundedPrim Word +buildVarint = buildVarintBase buildVarint8 + +buildVarint8 :: BoundedPrim Word +buildVarint8 = buildVarintBase buildVarint7 + +buildVarint7 :: BoundedPrim Word +buildVarint7 = buildVarintBase buildVarint6 + +buildVarint6 :: BoundedPrim Word +buildVarint6 = buildVarintBase buildVarint5 + +buildVarint5 :: BoundedPrim Word +buildVarint5 = buildVarintBase buildVarint4 + +buildVarint4 :: BoundedPrim Word +buildVarint4 = buildVarintBase buildVarint3 + +buildVarint3 :: BoundedPrim Word +buildVarint3 = buildVarintBase buildVarint2 + +buildVarint2 :: BoundedPrim Word +buildVarint2 = buildVarintBase buildVarint1 + +buildVarint1 :: BoundedPrim Word +buildVarint1 = buildVarintBase buildVarint0 + +buildVarint0 :: BoundedPrim Word +buildVarint0 = fromIntegral >$< liftFixedToBounded Prim.word8 + +{-# INLINE buildVarintBase #-} +buildVarintBase :: BoundedPrim Word -> BoundedPrim Word +buildVarintBase base = condB (\n -> n .&. complement 0x7F == 0) + buildVarint0 + ((\(W# n) -> + (mkW8# (0x80## `or#` (n `and#` 0x7f##)), W# (n `uncheckedShiftRL#` 7#))) >$< + (liftFixedToBounded Prim.word8 >*< base)) + where +#if __GLASGOW_HASKELL__ >= 902 + mkW8# x = W8# (wordToWord8# x) +#else + mkW8# = W8# +#endif + +{-# INLINE zigZagToInt #-} +zigZagToInt :: (Bits i, Integral i) => Word -> i +zigZagToInt w = fromIntegral (w `shiftR` 1) `xor` negate (fromIntegral w .&. 1) + +{-# INLINE parseVarint #-} +parseVarint :: Parser Word +parseVarint = go 0 0 + where + go !val !n = do + w <- anyWord8 + let newVal = val .|. (fromIntegral w .&. 0x7F) `shiftL` n + if not (testBit w 7) + then return newVal + else go newVal (n + 7) diff --git a/Thrift/Protocol/Id.hs b/Thrift/Protocol/Id.hs new file mode 100644 --- /dev/null +++ b/Thrift/Protocol/Id.hs @@ -0,0 +1,35 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Thrift.Protocol.Id + ( withProxy + , ProtocolId + , binaryProtocolId + , compactProtocolId + ) where + +import Control.Exception +import Data.Proxy +import Foreign.C +import Thrift.Protocol +import Thrift.Protocol.Binary +import Thrift.Protocol.Compact + +type ProtocolId = CUShort + +binaryProtocolId :: ProtocolId +binaryProtocolId = 0 + +compactProtocolId :: ProtocolId +compactProtocolId = 2 + +withProxy :: ProtocolId -> (forall p . Protocol p => Proxy p -> IO a) -> IO a +withProxy i action + | i == binaryProtocolId = action (Proxy :: Proxy Binary) + | i == compactProtocolId = action (Proxy :: Proxy Compact) + | otherwise = throw $ ProtocolException $ "unknown protocol id: " ++ show i diff --git a/Thrift/Protocol/JSON.hs b/Thrift/Protocol/JSON.hs new file mode 100644 --- /dev/null +++ b/Thrift/Protocol/JSON.hs @@ -0,0 +1,318 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeApplications #-} + +-- | Implementation of the Thrift Simple JSON Protocol +module Thrift.Protocol.JSON + ( serializeJSON, serializePrettyJSON + , deserializeJSON + , JSON + , keyToStr, hmMapKeys + ) where + +import Control.Arrow hiding (loop) +import Control.Monad +import Data.Aeson +import Data.Aeson.Encode.Pretty +import qualified Data.Aeson.Encoding as AE +import Thrift.Binary.Parser as P +import Data.ByteString (ByteString) +import Data.ByteString.Builder as B +import Data.ByteString.Builder.Prim as Prim +import Data.Function +import Data.Hashable +import Data.HashMap.Strict (HashMap) +import Data.List +import Data.Proxy +import Data.Text (Text) +import Data.Text.Encoding +import Data.Word8 +import GHC.Float +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as HashMap + +import Thrift.Protocol +import Thrift.Protocol.JSON.Base64 +import Thrift.Protocol.JSON.String + +-- | Implementation of TSimpleJSONProtocol +serializeJSON :: ThriftSerializable a => a -> ByteString +serializeJSON = serializeGen (Proxy :: Proxy JSON) + +-- | Pretty printed version of SimpleJSONProtocol +-- We still use Aeson here for now +serializePrettyJSON :: ThriftSerializable a => a -> ByteString +serializePrettyJSON = LBS.toStrict . encodePretty + +deserializeJSON :: ThriftSerializable a => ByteString -> Either String a +deserializeJSON = deserializeGen (Proxy :: Proxy JSON) + +-- Helper for converting Maps -------------------------------------------------- + +-- The keys of JSON Maps have to be Text, but in thrift they can be anything, so +-- we have these helpers to fix them up + +keyToStr :: ToJSON k => k -> Text +keyToStr = decodeUtf8 . LBS.toStrict . encode + +hmMapKeys :: (Eq b, Hashable b) => (a -> b) -> HashMap a x -> HashMap b x +hmMapKeys f = HashMap.fromList . map (first f) . HashMap.toList + +-- BinaryProtocol instance ----------------------------------------------------- + +data JSON + +#define COMMA 44 +#define COLON 58 +#define QUOTE 34 +#define LCURLY 123 +#define RCURLY 125 +#define LBRACK 91 +#define RBRACK 93 + +#define C_t 116 +#define C_f 102 +#define C_n 110 + +version1 :: Int +version1 = 1 + +-- These Type codes don't appear in the serialized data, rather we just make +-- them up in order to make sure that the value in the serialized data matches +-- what we expect. There are several types that we can't distinguish between +-- (eg numbers, lists/sets, etc) +numberTy, boolTy, strTy, listTy, structTy, nullTy :: Word8 +numberTy = 0 +boolTy = 1 +strTy = 2 +listTy = 3 +structTy = 4 +nullTy = 5 + +instance Protocol JSON where + -- Generators for Types + getByteType _ = numberTy + getI16Type _ = numberTy + getI32Type _ = numberTy + getI64Type _ = numberTy + getFloatType _ = numberTy + getDoubleType _ = numberTy + getBoolType _ = boolTy + getStringType _ = strTy + getListType _ = listTy + getSetType _ = listTy + getMapType _ = structTy + getStructType _ = structTy + + -- Generators for tokens + genMsgBegin _ name msgTy seqNum = + "[" <> B.intDec version1 <> + "," <> genEscString name <> + "," <> B.word8Dec msgTy <> + "," <> B.int32Dec seqNum <> + "," + genMsgEnd _ = "]" + + genStruct _ fields = "{" <> mconcat (intersperse "," fields) <> "}" + + genField _ name _ _ _ val = genEscString name <> ":" <> val + genFieldPrim _ name _ _ _ prim val = + genEscString name <> ":" <> primBounded prim val + + genList _ _ build elems = + "[" <> mconcat (intersperse "," (map build elems)) <> "]" + + genListPrim p ty prim = genList p ty (primBounded prim) + + genMap _ _ _ isString kbuild vbuild elems = + "{" <> mconcat (intersperse "," (map build elems)) <> "}" + where + build (k, v) + | isString = kbuild k <> ":" <> vbuild v + | otherwise = "\"" <> kbuild k <> "\":" <> vbuild v + + genMapPrim p k v b kb vb = genMap p k v b (primBounded kb) (primBounded vb) + + -- Generators for base types + genBytePrim _ = Prim.int8Dec + genI16Prim _ = Prim.int16Dec + genI32Prim _ = Prim.int32Dec + genI64Prim _ = Prim.int64Dec + genFloat _ num + | isNaN num = Prim.primMapListFixed Prim.char7 "\"NaN\"" + -- Generate x rather than x.0, like C++'s serializer + | num == fromInteger (round num) = B.intDec $ round num + | otherwise = floatDec num + genDouble _ num + | isNaN num = Prim.primMapListFixed Prim.char7 "\"NaN\"" + -- Generate x rather than x.0, like C++'s serializer + | num == fromInteger (round num) = B.intDec $ round num + | otherwise = doubleDec num + genBoolPrim _ = (condB id `on` liftFixedToBounded) + (const ('t', ('r', ('u', 'e'))) >$< + (Prim.char7 >*< Prim.char7 >*< Prim.char7 >*< Prim.char7)) + (const ('f', ('a', ('l', ('s', 'e')))) >$< + (Prim.char7 >*< Prim.char7 >*< Prim.char7 >*< Prim.char7 >*< Prim.char7)) + + genText _ = genEscString + genBytes _ bs = "\"" <> encodeBase64 bs <> "\"" + + -- Parsers for tokens + parseMsgBegin _ = do + _ <- skipSpaces *> P.word8 LBRACK + version <- skipSpaces *> parseJSONInt + when (version /= version1) $ fail "parseMsgBegin: invalid version" + _ <- skipSpaces *> P.word8 COMMA + name <- parseJSONString + _ <- skipSpaces *> P.word8 COMMA + msgType <- parseJSONInt + _ <- skipSpaces *> P.word8 COMMA + seqNum <- parseJSONInt + _ <- skipSpaces *> P.word8 COMMA + return $ MsgBegin name msgType seqNum + parseMsgEnd _ = void $ skipSpaces *> P.word8 RBRACK + + parseFieldBegin _ lastId idMap = do + w <- skipSpaces *> anyWord8 + case w of + -- If we get a '{' then the struct might be empty + LCURLY | lastId == 0 -> do + c <- skipSpaces *> P.peek + case c of + RCURLY -> FieldEnd <$ anyWord8 + _ -> go + COMMA -> go + RCURLY -> pure FieldEnd + _ -> fail $ "no field " ++ show w ++ " " ++ show lastId + where + go = do + name <- parseJSONString + _ <- skipSpaces *> P.word8 COLON + case HashMap.lookup name idMap of + Just fid -> do + c <- skipSpaces *> P.peek + let + ty = case c of + LCURLY -> structTy + LBRACK -> listTy + QUOTE -> strTy + C_f -> boolTy + C_t -> boolTy + C_n -> nullTy + _ -> numberTy + pure $ FieldBegin ty fid False + -- Inserting a 0xFF type code ensures that this won't match with + -- anything + Nothing -> pure $ FieldBegin 0xFF (-1) False + + -- Parser for base types + parseByte _ = parseJSONInt + parseI16 _ = parseJSONInt + parseI32 _ = parseJSONInt + parseI64 _ = parseJSONInt + parseFloat _ = double2Float <$> parseJSONDouble + parseDouble _ = parseJSONDouble + parseBool _ = parseJSONBool + parseBoolF _ _ = parseJSONBool + parseText _ = parseJSONString + parseBytes _ = do + raw <- P.word8 QUOTE *> P.takeWhile (/= QUOTE) <* P.word8 QUOTE + return $ decodeBase64 raw + + parseList _ p = do + _ <- skipSpaces *> P.word8 LBRACK + w <- skipSpaces *> P.peek + if w == RBRACK then anyWord8 *> pure (0,[]) else loop 1 [] + where + loop !n xs = do + x <- skipSpaces *> p + w <- skipSpaces *> anyWord8 + case w of + RBRACK -> pure (n, reverse (x:xs)) + COMMA -> loop (n+1) (x:xs) + _ -> fail "invalid list" + + parseMap _ pk pv isString = do + _ <- skipSpaces *> P.word8 LCURLY + w <- skipSpaces *> P.peek + if w == RCURLY then anyWord8 *> pure [] else loop + where + loop = do + skipSpaces + key <- if isString then pk else P.word8 QUOTE *> pk <* P.word8 QUOTE + _ <- skipSpaces *> P.word8 COLON + val <- skipSpaces *> pv + w <- skipSpaces *> anyWord8 + case w of + RCURLY -> pure [(key, val)] + COMMA -> ((key, val) :) <$> loop + _ -> fail "invalid map" + + parseSkip _ _ _ = do + c <- skipSpaces *> P.peek + case c of + LCURLY -> skipObj + LBRACK -> skipList + QUOTE -> void $ parseJSONString + C_f -> void $ string "false" + C_t -> void $ string "true" + C_n -> void $ string "null" + _ | c >= _0 && c <= _9 || c == _hyphen -> void double + | otherwise -> fail "not a valid json value" + +skipObj :: Parser () +skipObj = do + _ <- P.word8 LCURLY + _ <- sepBy skipInner $ skipSpaces *> P.word8 COMMA + _ <- skipSpaces *> P.word8 RCURLY + return () + where + skipInner = do + _ <- skipSpaces *> parseSkip (Proxy @JSON) 1 Nothing + _ <- skipSpaces *> P.word8 COLON + skipSpaces *> parseSkip (Proxy @JSON) 1 Nothing + +skipList :: Parser () +skipList = do + _ <- P.word8 LBRACK + _ <- sepBy skipInner $ skipSpaces *> P.word8 COMMA + _ <- skipSpaces *> P.word8 RBRACK + return () + where + skipInner = skipSpaces *> parseSkip (Proxy @JSON) 1 Nothing + +-- Use Aeson to escape a string +genEscString :: Text -> B.Builder +genEscString = fromEncoding . AE.text + +{-# INLINE parseJSONInt #-} +parseJSONInt :: Integral a => Parser a +parseJSONInt = lexeme $ signed decimal + +{-# INLINE parseJSONBool #-} +parseJSONBool :: Parser Bool +parseJSONBool = do + skipSpaces + w <- anyWord8 + if | w == C_t -> True <$ string "rue" + | w == C_f -> False <$ string "alse" + | otherwise -> fail "expected boolean" + +{-# INLINE parseJSONDouble #-} +parseJSONDouble :: Parser Double +parseJSONDouble = do + c <- skipSpaces *> P.peek + if | c == QUOTE -> string "\"NaN\"" >> return (0/0) + | otherwise -> double + + +{-# INLINE lexeme #-} +lexeme :: Parser a -> Parser a +lexeme = (skipSpaces *>) diff --git a/Thrift/Protocol/JSON/Base64.hs b/Thrift/Protocol/JSON/Base64.hs new file mode 100644 --- /dev/null +++ b/Thrift/Protocol/JSON/Base64.hs @@ -0,0 +1,106 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Thrift.Protocol.JSON.Base64 + ( encodeBase64 + , encodeBase64Text + , decodeBase64 + ) where + +import Data.Bits +import Data.ByteString.Builder +import Data.ByteString.Builder.Prim as Prim +import Data.ByteString.Internal +import Data.ByteString.Lazy (toStrict) +import Data.Text (Text) +import Data.Word +import Data.Vector ((!)) +import qualified Data.ByteString as BS +import qualified Data.Text as Text +import qualified Data.Vector as Vector + +symbol :: Word8 -> Word8 +symbol w = BS.index + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" + (fromIntegral w) + +encodeBase64 :: ByteString -> Builder +encodeBase64 = encode . BS.unpack + where + -- case 1: len >= 3 + encode (b0 : b1 : b2 : bs) = primFixed + (Prim.word8 >*< Prim.word8 >*< Prim.word8 >*< Prim.word8) + (symbol $ (b0 `shiftR` 2) .&. 0x3f, + (symbol $ ((b0 `shiftL` 4) .&. 0x30) .|. ((b1 `shiftR` 4) .&. 0x0f), + (symbol $ ((b1 `shiftL` 2) .&. 0x3c) .|. ((b2 `shiftR` 6) .&. 0x03), + symbol $ b2 .&. 0x3f))) <> + encode bs + -- case 2: len == 2 + encode [b0, b1] = primFixed + (Prim.word8 >*< Prim.word8 >*< Prim.word8) + (symbol $ (b0 `shiftR` 2) .&. 0x3f, + (symbol $ ((b0 `shiftL` 4) .&. 0x30) .|. ((b1 `shiftR` 4) .&. 0x0f), + symbol $ (b1 `shiftL` 2) .&. 0x3c)) + -- case 3: len == 1 + encode [b0] = primFixed + (Prim.word8 >*< Prim.word8) + (symbol $ (b0 `shiftR` 2) .&. 0x3f, + symbol $ (b0 `shiftL` 4) .&. 0x30) + -- case 4: len == 0 (impossible) + encode [] = mempty + +encodeBase64Text :: ByteString -> Text +encodeBase64Text = + Text.pack . map w2c . BS.unpack . toStrict . toLazyByteString . encodeBase64 + +decodeTable :: Word8 -> Word8 +decodeTable = (table!) . fromIntegral + where + table = Vector.fromList + [ 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff + , 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff + , 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff + , 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x3e, 0xff, 0xff, 0xff, 0x3f + , 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3a, 0x3b, 0x3c, 0x3d, 0xff, 0xff + , 0xff, 0xff, 0xff, 0xff, 0xff, 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06 + , 0x07, 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x10, 0x11, 0x12 + , 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x19, 0xff, 0xff, 0xff, 0xff, 0xff + , 0xff, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, 0x20, 0x21, 0x22, 0x23, 0x24 + , 0x25, 0x26, 0x27, 0x28, 0x29, 0x2a, 0x2b, 0x2c, 0x2d, 0x2e, 0x2f, 0x30 + , 0x31, 0x32, 0x33, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff + , 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff + , 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff + , 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff + , 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff + , 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff + , 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff + , 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff + , 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff + , 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff + , 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff + , 0xff, 0xff, 0xff, 0xff + ] + +decodeBase64 :: ByteString -> ByteString +decodeBase64 = BS.pack . decode . BS.unpack + where + decode (b0 : b1 : b2 : b3 : bs) = + decode0 b0 b1 : decode1 b1 b2 : decode2 b2 b3 : decode bs + decode [b0, b1, b2] = [decode0 b0 b1, decode1 b1 b2] + decode [b0, b1] = [decode0 b0 b1] + decode _ = [] + + decode0 b0 b1 = + (decodeTable b0 `shiftL` 2) .|. + (decodeTable b1 `shiftR` 4) + decode1 b1 b2 = + ((decodeTable b1 `shiftL` 4) .&. 0xf0) .|. + (decodeTable b2 `shiftR` 2) + decode2 b2 b3 = + ((decodeTable b2 `shiftL` 6) .&. 0xc0) .|. + decodeTable b3 diff --git a/Thrift/Protocol/JSON/String.hs b/Thrift/Protocol/JSON/String.hs new file mode 100644 --- /dev/null +++ b/Thrift/Protocol/JSON/String.hs @@ -0,0 +1,173 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# OPTIONS_GHC -fprof-auto #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NondecreasingIndentation #-} +module Thrift.Protocol.JSON.String + ( parseJSONString + ) where + +import Control.Exception +import Control.Monad +import Thrift.Binary.Parser +import Data.Bits +import qualified Data.ByteString as ByteString +import Data.ByteString.Internal (ByteString(..)) +import Data.ByteString.Unsafe +import Data.Char +import Data.Text (Text) +import Data.Text.Encoding +import Data.Word +import Data.Word8 +import Foreign.ForeignPtr +import Foreign.Ptr +import Foreign.Storable +import System.IO.Unsafe + +import Util.FFI + +parseJSONString :: Parser Text +parseJSONString = do + skipSpaces *> word8 _quotedbl + rawBytes <- peekBS + case unescape rawBytes of + Left (StringError err) -> fail err + Right (UnescapeResult bytes inLen) -> do + skipN (inLen + 1) -- Skip over the string and closing " + case decodeUtf8' bytes of + Left err -> fail $ show err + Right txt -> return txt + +-- NOTE: The cpp2 implementation only accepts escaped "unicode" characters of +-- the form "\u00XX" where the X's are hex digits, so we will do the same here. +-- This means that all \u characters fit into a single byte which simplifies the +-- unescaping logic signifigantly + +-- Datatype where all fields are strict so that we can avoid calling `evaluate` +data UnescapeResult = UnescapeResult !ByteString {-# UNPACK #-} !Int + +-- Low-level unescaping logic. Works on the underlying byte array +unescape :: ByteString -> Either StringError UnescapeResult +unescape rawBytes = unsafeDupablePerformIO $ try $ + unsafeUseAsCStringLen rawBytes $ \(charBuf, fullLen) -> do + let input = castPtr charBuf :: Ptr Word8 + + -- Find the lengths of the input and output + (inLen, outLen) <- unescapedLength input fullLen + + -- If the input has the same length as the output, then there are no escape + -- characters, so we can just return the ByteString as is + if inLen == outLen + then return $! UnescapeResult (ByteString.take outLen rawBytes) inLen + else do + + -- Allocate a buffer for the output + outBuf <- mallocForeignPtrArray outLen + unsafeWithForeignPtr outBuf $ \output -> do + let + -- Unescape the input character by character. + -- i is the input index and j is the output index + go !i !j + | j >= outLen = return () + | otherwise = do + byte <- peekByteOff input i + if + -- Case 1: we have reached an escape character + -- NOTE: no bounds checks are needed because we already checked + -- bounds in unescapeLength + | byte == _backslash -> do + escChr <- peekByteOff input $ i + 1 + if + -- Case 1.1: We have reached a 4-hex-digit unicode point + | escChr == _u -> do + c <- parseUnicodeChar =<< + peekByteOff (castPtr input) (i + 2) + pokeByteOff output j c + go (i + 6) (j + 1) + -- Case 1.2: Byte is a valid escape char + | Just unesc <- unescapeChar escChr -> do + pokeByteOff output j unesc + go (i + 2) (j + 1) + -- Case 1.3: Invalid escape character + | otherwise -> + throwIO $ StringError $ + "parseJSONString: Not a valid escape character: " ++ + [chr $ fromIntegral byte] + -- Case 2: Not an escape character + | otherwise -> do + pokeByteOff output j byte + go (i + 1) (j + 1) + go 0 0 + return $! UnescapeResult (PS outBuf 0 outLen) inLen + +{-# INLINE unescapedLength #-} +-- Get the escaped and unescaped lengths of the input +unescapedLength :: Ptr Word8 -> Int -> IO (Int, Int) +unescapedLength buf len = go 0 0 + where + -- In this function i is the index in the input and j is the output length + go !i !j + | i >= len = stringError + | otherwise = do + byte <- peekByteOff buf i + if | byte == _quotedbl -> return (i, j) + | byte == _backslash -> + if i + 1 < len + then do + nextByte <- peekByteOff buf (i + 1) + if | nextByte == _u -> go (i + 6) (j + 1) -- skip over \uXXXX + | otherwise -> go (i + 2) (j + 1) -- skip over \X + else stringError + | otherwise -> go (i + 1) (j + 1) + stringError = + throwIO $ StringError "parseJSONString: string does not terminate" + +{-# INLINE unescapeChar #-} +unescapeChar :: Word8 -> Maybe Word8 +unescapeChar = \case + 0x22 {- " -} -> Just _quotedbl + 0x27 {- ' -} -> Just _quotesingle + 0x2F {- / -} -> Just _slash + 0x5C {- \ -} -> Just _backslash + 0x30 {- 0 -} -> Just _0 + 0x61 {- a -} -> Just $ fromIntegral $ ord '\a' + 0x62 {- b -} -> Just $ fromIntegral $ ord '\b' + 0x66 {- f -} -> Just $ fromIntegral $ ord '\f' + 0x6E {- n -} -> Just _lf -- linefeed + 0x72 {- r -} -> Just _cr -- carriage return + 0x74 {- t -} -> Just _tab + 0x76 {- v -} -> Just _vt -- vertical tab + _ -> Nothing + +{-# INLINE parseUnicodeChar #-} +parseUnicodeChar :: Word32 -> IO Word8 +parseUnicodeChar !word = do + -- Must have the form '\u00XX' (see note above). + -- 0x30 is the acsii character '0' + unless (word .&. 0x0000FFFF == 0x3030) unicodeError + d0 <- hexdigit $ fromIntegral $ (word `shiftR` 16) .&. 0x000000FF + d1 <- hexdigit $ fromIntegral $ (word `shiftR` 24) .&. 0x000000FF + return $ d0 `shiftL` 4 .|. d1 + where + unicodeError = throwIO $ StringError "Improperly formatted unicode string" + hexdigit :: Word8 -> IO Word8 + hexdigit n + | n `inRange` (_0, _9) = pure $ n - _0 + | n `inRange` (_a, _f) = pure $ n - _a + 10 + | n `inRange` (_A, _F) = pure $ n - _A + 10 + | otherwise = unicodeError + +inRange :: Word8 -> (Word8, Word8) -> Bool +inRange n (x, y) = n >= x && n <= y + +newtype StringError = StringError String + deriving Show + +instance Exception StringError diff --git a/Thrift/Util.hs b/Thrift/Util.hs new file mode 100644 --- /dev/null +++ b/Thrift/Util.hs @@ -0,0 +1,46 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Thrift.Util + ( loadJSON + , saveJSON + , ThriftException(..) + , prettyThrift + ) where + +import Control.Exception +import Data.Aeson +import Data.Aeson.Encode.Pretty +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy.Char8 as LB +import Thrift.Protocol +import Thrift.Protocol.JSON + +newtype ThriftException = ThriftException String + deriving Show + +instance Exception ThriftException + +-- | Load a Thrift value from a file using the PrettyJSON protocol +loadJSON :: ThriftSerializable a => FilePath -> IO a +loadJSON path = do + result <- deserializeJSON <$> BS.readFile path + case result of + Left err -> throwIO $ ThriftException $ "[" ++ path ++ "] " ++ err + Right struct -> return struct + +-- | Save a Thrift value to a file using the PrettyJSON protocol +saveJSON :: ThriftSerializable a => FilePath -> a -> IO () +saveJSON path value = BS.writeFile path $ serializePrettyJSON value + +-- | Render a Thrift value as prettified JSON +prettyThrift :: ThriftSerializable a => a -> LB.ByteString +prettyThrift a = + case eitherDecode (LB.fromStrict (serializeJSON a)) of + Right obj -> encodePretty (obj :: Object) + Left err -> LB.pack err diff --git a/gen-hs2/Thrift/Protocol/ApplicationException/Types.hs b/gen-hs2/Thrift/Protocol/ApplicationException/Types.hs new file mode 100644 --- /dev/null +++ b/gen-hs2/Thrift/Protocol/ApplicationException/Types.hs @@ -0,0 +1,249 @@ +----------------------------------------------------------------- +-- Autogenerated by Thrift +-- +-- DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING +-- @generated +----------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports#-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-record-updates#-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Thrift.Protocol.ApplicationException.Types + (ApplicationExceptionType(ApplicationExceptionType_Unknown, + ApplicationExceptionType_UnknownMethod, + ApplicationExceptionType_InvalidMessageType, + ApplicationExceptionType_WrongMethodType, + ApplicationExceptionType_BadSequenceId, + ApplicationExceptionType_MissingResult, + ApplicationExceptionType_InternalError, + ApplicationExceptionType_ProtocolError, + ApplicationExceptionType_InvalidTransform, + ApplicationExceptionType_InvalidProtocol, + ApplicationExceptionType_UnsupportedClientType, + ApplicationExceptionType_Loadshedding, + ApplicationExceptionType_Timeout, + ApplicationExceptionType_InjectedFailure, + ApplicationExceptionType__UNKNOWN), + ApplicationException(ApplicationException, + applicationException_message, applicationException_type)) + where +import qualified Control.DeepSeq as DeepSeq +import qualified Control.Exception as Exception +import qualified Control.Monad as Monad +import qualified Control.Monad.ST.Trans as ST +import qualified Control.Monad.Trans.Class as Trans +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import qualified Data.Default as Default +import qualified Data.Function as Function +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Hashable as Hashable +import qualified Data.Int as Int +import qualified Data.List as List +import qualified Data.Ord as Ord +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified GHC.Magic as GHC +import qualified Prelude as Prelude +import qualified Thrift.Binary.Parser as Parser +import qualified Thrift.CodegenTypesOnly as Thrift +import Control.Applicative ((<|>), (*>), (<*)) +import Data.Aeson ((.:), (.:?), (.=), (.!=)) +import Data.Monoid ((<>)) +import Prelude ((.), (++), (>), (==)) +import Prelude ((.), (<$>), (<*>), (>>=), (==), (/=), (<), (++)) + +data ApplicationExceptionType = ApplicationExceptionType_Unknown + | ApplicationExceptionType_UnknownMethod + | ApplicationExceptionType_InvalidMessageType + | ApplicationExceptionType_WrongMethodType + | ApplicationExceptionType_BadSequenceId + | ApplicationExceptionType_MissingResult + | ApplicationExceptionType_InternalError + | ApplicationExceptionType_ProtocolError + | ApplicationExceptionType_InvalidTransform + | ApplicationExceptionType_InvalidProtocol + | ApplicationExceptionType_UnsupportedClientType + | ApplicationExceptionType_Loadshedding + | ApplicationExceptionType_Timeout + | ApplicationExceptionType_InjectedFailure + | ApplicationExceptionType__UNKNOWN Prelude.Int + deriving (Prelude.Eq, Prelude.Show, Prelude.Ord) + +instance Aeson.ToJSON ApplicationExceptionType where + toJSON = Aeson.toJSON . Thrift.fromThriftEnum + +instance DeepSeq.NFData ApplicationExceptionType where + rnf __ApplicationExceptionType + = Prelude.seq __ApplicationExceptionType () + +instance Default.Default ApplicationExceptionType where + def = ApplicationExceptionType_Unknown + +instance Hashable.Hashable ApplicationExceptionType where + hashWithSalt _salt _val + = Hashable.hashWithSalt _salt (Thrift.fromThriftEnum _val) + +instance Thrift.ThriftEnum ApplicationExceptionType where + toThriftEnum 0 = ApplicationExceptionType_Unknown + toThriftEnum 1 = ApplicationExceptionType_UnknownMethod + toThriftEnum 2 = ApplicationExceptionType_InvalidMessageType + toThriftEnum 3 = ApplicationExceptionType_WrongMethodType + toThriftEnum 4 = ApplicationExceptionType_BadSequenceId + toThriftEnum 5 = ApplicationExceptionType_MissingResult + toThriftEnum 6 = ApplicationExceptionType_InternalError + toThriftEnum 7 = ApplicationExceptionType_ProtocolError + toThriftEnum 8 = ApplicationExceptionType_InvalidTransform + toThriftEnum 9 = ApplicationExceptionType_InvalidProtocol + toThriftEnum 10 = ApplicationExceptionType_UnsupportedClientType + toThriftEnum 11 = ApplicationExceptionType_Loadshedding + toThriftEnum 12 = ApplicationExceptionType_Timeout + toThriftEnum 13 = ApplicationExceptionType_InjectedFailure + toThriftEnum val = ApplicationExceptionType__UNKNOWN val + fromThriftEnum ApplicationExceptionType_Unknown = 0 + fromThriftEnum ApplicationExceptionType_UnknownMethod = 1 + fromThriftEnum ApplicationExceptionType_InvalidMessageType = 2 + fromThriftEnum ApplicationExceptionType_WrongMethodType = 3 + fromThriftEnum ApplicationExceptionType_BadSequenceId = 4 + fromThriftEnum ApplicationExceptionType_MissingResult = 5 + fromThriftEnum ApplicationExceptionType_InternalError = 6 + fromThriftEnum ApplicationExceptionType_ProtocolError = 7 + fromThriftEnum ApplicationExceptionType_InvalidTransform = 8 + fromThriftEnum ApplicationExceptionType_InvalidProtocol = 9 + fromThriftEnum ApplicationExceptionType_UnsupportedClientType = 10 + fromThriftEnum ApplicationExceptionType_Loadshedding = 11 + fromThriftEnum ApplicationExceptionType_Timeout = 12 + fromThriftEnum ApplicationExceptionType_InjectedFailure = 13 + fromThriftEnum (ApplicationExceptionType__UNKNOWN val) = val + allThriftEnumValues + = [ApplicationExceptionType_Unknown, + ApplicationExceptionType_UnknownMethod, + ApplicationExceptionType_InvalidMessageType, + ApplicationExceptionType_WrongMethodType, + ApplicationExceptionType_BadSequenceId, + ApplicationExceptionType_MissingResult, + ApplicationExceptionType_InternalError, + ApplicationExceptionType_ProtocolError, + ApplicationExceptionType_InvalidTransform, + ApplicationExceptionType_InvalidProtocol, + ApplicationExceptionType_UnsupportedClientType, + ApplicationExceptionType_Loadshedding, + ApplicationExceptionType_Timeout, + ApplicationExceptionType_InjectedFailure] + toThriftEnumEither 0 + = Prelude.Right ApplicationExceptionType_Unknown + toThriftEnumEither 1 + = Prelude.Right ApplicationExceptionType_UnknownMethod + toThriftEnumEither 2 + = Prelude.Right ApplicationExceptionType_InvalidMessageType + toThriftEnumEither 3 + = Prelude.Right ApplicationExceptionType_WrongMethodType + toThriftEnumEither 4 + = Prelude.Right ApplicationExceptionType_BadSequenceId + toThriftEnumEither 5 + = Prelude.Right ApplicationExceptionType_MissingResult + toThriftEnumEither 6 + = Prelude.Right ApplicationExceptionType_InternalError + toThriftEnumEither 7 + = Prelude.Right ApplicationExceptionType_ProtocolError + toThriftEnumEither 8 + = Prelude.Right ApplicationExceptionType_InvalidTransform + toThriftEnumEither 9 + = Prelude.Right ApplicationExceptionType_InvalidProtocol + toThriftEnumEither 10 + = Prelude.Right ApplicationExceptionType_UnsupportedClientType + toThriftEnumEither 11 + = Prelude.Right ApplicationExceptionType_Loadshedding + toThriftEnumEither 12 + = Prelude.Right ApplicationExceptionType_Timeout + toThriftEnumEither 13 + = Prelude.Right ApplicationExceptionType_InjectedFailure + toThriftEnumEither val + = Prelude.Left + ("toThriftEnumEither: not a valid identifier for enum ApplicationExceptionType: " + ++ Prelude.show val) + +data ApplicationException = ApplicationException{applicationException_message + :: Text.Text, + applicationException_type :: + ApplicationExceptionType} + deriving (Prelude.Eq, Prelude.Show, Prelude.Ord) + +instance Aeson.ToJSON ApplicationException where + toJSON (ApplicationException __field__message __field__type) + = Aeson.object + ("message" .= __field__message : + "type" .= __field__type : Prelude.mempty) + +instance Thrift.ThriftStruct ApplicationException where + buildStruct _proxy + (ApplicationException __field__message __field__type) + = Thrift.genStruct _proxy + (Thrift.genField _proxy "message" (Thrift.getStringType _proxy) 1 0 + (Thrift.genText _proxy __field__message) + : + Thrift.genField _proxy "type" (Thrift.getI32Type _proxy) 2 1 + ((Thrift.genI32 _proxy . Prelude.fromIntegral . + Thrift.fromThriftEnum) + __field__type) + : []) + parseStruct _proxy + = ST.runSTT + (do Prelude.return () + __field__message <- ST.newSTRef "" + __field__type <- ST.newSTRef Default.def + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 1 | _type == + Thrift.getStringType _proxy + -> + do !_val <- Trans.lift + (Thrift.parseText + _proxy) + ST.writeSTRef + __field__message + _val + 2 | _type == + Thrift.getI32Type _proxy + -> + do !_val <- Trans.lift + (Thrift.parseEnum + _proxy + "ApplicationExceptionType") + ST.writeSTRef __field__type + _val + _ -> Trans.lift + (Thrift.parseSkip _proxy + _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do !__val__message <- ST.readSTRef + __field__message + !__val__type <- ST.readSTRef __field__type + Prelude.pure + (ApplicationException __val__message __val__type) + _idMap = HashMap.fromList [("message", 1), ("type", 2)] + _parse 0) + +instance DeepSeq.NFData ApplicationException where + rnf (ApplicationException __field__message __field__type) + = DeepSeq.rnf __field__message `Prelude.seq` + DeepSeq.rnf __field__type `Prelude.seq` () + +instance Default.Default ApplicationException where + def = ApplicationException "" Default.def + +instance Hashable.Hashable ApplicationException where + hashWithSalt __salt (ApplicationException _message _type) + = Hashable.hashWithSalt (Hashable.hashWithSalt __salt _message) + _type + +instance Exception.Exception ApplicationException diff --git a/gen-hs2/Thrift/Protocol/RpcOptions/Types.hs b/gen-hs2/Thrift/Protocol/RpcOptions/Types.hs new file mode 100644 --- /dev/null +++ b/gen-hs2/Thrift/Protocol/RpcOptions/Types.hs @@ -0,0 +1,282 @@ +----------------------------------------------------------------- +-- Autogenerated by Thrift +-- +-- DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING +-- @generated +----------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports#-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-record-updates#-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Thrift.Protocol.RpcOptions.Types + (Priority(HighImportant, High, Important, NormalPriority, + BestEffort, Priority__UNKNOWN), + RpcOptions(RpcOptions, rpc_timeout, rpc_priority, rpc_chunkTimeout, + rpc_queueTimeout, rpc_headers)) + where +import qualified Control.DeepSeq as DeepSeq +import qualified Control.Exception as Exception +import qualified Control.Monad as Monad +import qualified Control.Monad.ST.Trans as ST +import qualified Control.Monad.Trans.Class as Trans +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import qualified Data.Default as Default +import qualified Data.Function as Function +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Hashable as Hashable +import qualified Data.Int as Int +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import qualified Data.Ord as Ord +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified GHC.Magic as GHC +import qualified Prelude as Prelude +import qualified Thrift.Binary.Parser as Parser +import qualified Thrift.CodegenTypesOnly as Thrift +import Control.Applicative ((<|>), (*>), (<*)) +import Data.Aeson ((.:), (.:?), (.=), (.!=)) +import Data.Monoid ((<>)) +import Prelude ((.), (++), (>), (==)) +import Prelude ((.), (<$>), (<*>), (>>=), (==), (/=), (<), (++)) + +data Priority = HighImportant + | High + | Important + | NormalPriority + | BestEffort + | Priority__UNKNOWN Prelude.Int + deriving (Prelude.Eq, Prelude.Show, Prelude.Ord) + +instance Aeson.ToJSON Priority where + toJSON = Aeson.toJSON . Thrift.fromThriftEnum + +instance DeepSeq.NFData Priority where + rnf __Priority = Prelude.seq __Priority () + +instance Default.Default Priority where + def = HighImportant + +instance Hashable.Hashable Priority where + hashWithSalt _salt _val + = Hashable.hashWithSalt _salt (Thrift.fromThriftEnum _val) + +instance Thrift.ThriftEnum Priority where + toThriftEnum 0 = HighImportant + toThriftEnum 1 = High + toThriftEnum 2 = Important + toThriftEnum 3 = NormalPriority + toThriftEnum 4 = BestEffort + toThriftEnum val = Priority__UNKNOWN val + fromThriftEnum HighImportant = 0 + fromThriftEnum High = 1 + fromThriftEnum Important = 2 + fromThriftEnum NormalPriority = 3 + fromThriftEnum BestEffort = 4 + fromThriftEnum (Priority__UNKNOWN val) = val + allThriftEnumValues + = [HighImportant, High, Important, NormalPriority, BestEffort] + toThriftEnumEither 0 = Prelude.Right HighImportant + toThriftEnumEither 1 = Prelude.Right High + toThriftEnumEither 2 = Prelude.Right Important + toThriftEnumEither 3 = Prelude.Right NormalPriority + toThriftEnumEither 4 = Prelude.Right BestEffort + toThriftEnumEither val + = Prelude.Left + ("toThriftEnumEither: not a valid identifier for enum Priority: " + ++ Prelude.show val) + +data RpcOptions = RpcOptions{rpc_timeout :: Int.Int32, + rpc_priority :: Prelude.Maybe Priority, + rpc_chunkTimeout :: Int.Int32, rpc_queueTimeout :: Int.Int32, + rpc_headers :: Prelude.Maybe (Map.Map Text.Text Text.Text)} + deriving (Prelude.Eq, Prelude.Show, Prelude.Ord) + +instance Aeson.ToJSON RpcOptions where + toJSON + (RpcOptions __field__timeout __field__priority + __field__chunkTimeout __field__queueTimeout __field__headers) + = Aeson.object + ("timeout" .= __field__timeout : + Prelude.maybe Prelude.id ((:) . ("priority" .=)) __field__priority + ("chunkTimeout" .= __field__chunkTimeout : + "queueTimeout" .= __field__queueTimeout : + Prelude.maybe Prelude.id ((:) . ("headers" .=)) __field__headers + Prelude.mempty)) + +instance Thrift.ThriftStruct RpcOptions where + buildStruct _proxy + (RpcOptions __field__timeout __field__priority + __field__chunkTimeout __field__queueTimeout __field__headers) + = Thrift.genStruct _proxy + (Thrift.genFieldPrim _proxy "timeout" (Thrift.getI32Type _proxy) 1 + 0 + (Thrift.genI32Prim _proxy) + __field__timeout + : + let (__cereal__priority, __id__priority) + = case __field__priority of + Prelude.Just _val -> ((:) + (Thrift.genField _proxy "priority" + (Thrift.getI32Type _proxy) + 2 + 1 + ((Thrift.genI32 _proxy . Prelude.fromIntegral . + Thrift.fromThriftEnum) + _val)), + 2) + Prelude.Nothing -> (Prelude.id, 1) + in + __cereal__priority + (Thrift.genFieldPrim _proxy "chunkTimeout" + (Thrift.getI32Type _proxy) + 3 + __id__priority + (Thrift.genI32Prim _proxy) + __field__chunkTimeout + : + Thrift.genFieldPrim _proxy "queueTimeout" + (Thrift.getI32Type _proxy) + 4 + 3 + (Thrift.genI32Prim _proxy) + __field__queueTimeout + : + case __field__headers of + Prelude.Just _val -> Thrift.genField _proxy "headers" + (Thrift.getMapType _proxy) + 5 + 4 + ((Thrift.genMap _proxy (Thrift.getStringType _proxy) + (Thrift.getStringType _proxy) + Prelude.True + (Thrift.genText _proxy) + (Thrift.genText _proxy) + . Map.toList) + _val) + : [] + Prelude.Nothing -> [])) + parseStruct _proxy + = ST.runSTT + (do Prelude.return () + __field__timeout <- ST.newSTRef Default.def + __field__priority <- ST.newSTRef Prelude.Nothing + __field__chunkTimeout <- ST.newSTRef Default.def + __field__queueTimeout <- ST.newSTRef Default.def + __field__headers <- ST.newSTRef Prelude.Nothing + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 1 | _type == + Thrift.getI32Type _proxy + -> + do !_val <- Trans.lift + (Thrift.parseI32 + _proxy) + ST.writeSTRef + __field__timeout + _val + 2 | _type == + Thrift.getI32Type _proxy + -> + do !_val <- Trans.lift + (Thrift.parseEnum + _proxy + "Priority") + ST.writeSTRef + __field__priority + (Prelude.Just _val) + 3 | _type == + Thrift.getI32Type _proxy + -> + do !_val <- Trans.lift + (Thrift.parseI32 + _proxy) + ST.writeSTRef + __field__chunkTimeout + _val + 4 | _type == + Thrift.getI32Type _proxy + -> + do !_val <- Trans.lift + (Thrift.parseI32 + _proxy) + ST.writeSTRef + __field__queueTimeout + _val + 5 | _type == + Thrift.getMapType _proxy + -> + do !_val <- Trans.lift + (Map.fromList <$> + Thrift.parseMap + _proxy + (Thrift.parseText + _proxy) + (Thrift.parseText + _proxy) + Prelude.True) + ST.writeSTRef + __field__headers + (Prelude.Just _val) + _ -> Trans.lift + (Thrift.parseSkip _proxy + _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do !__val__timeout <- ST.readSTRef + __field__timeout + !__val__priority <- ST.readSTRef __field__priority + !__val__chunkTimeout <- ST.readSTRef + __field__chunkTimeout + !__val__queueTimeout <- ST.readSTRef + __field__queueTimeout + !__val__headers <- ST.readSTRef __field__headers + Prelude.pure + (RpcOptions __val__timeout __val__priority + __val__chunkTimeout + __val__queueTimeout + __val__headers) + _idMap + = HashMap.fromList + [("timeout", 1), ("priority", 2), ("chunkTimeout", 3), + ("queueTimeout", 4), ("headers", 5)] + _parse 0) + +instance DeepSeq.NFData RpcOptions where + rnf + (RpcOptions __field__timeout __field__priority + __field__chunkTimeout __field__queueTimeout __field__headers) + = DeepSeq.rnf __field__timeout `Prelude.seq` + DeepSeq.rnf __field__priority `Prelude.seq` + DeepSeq.rnf __field__chunkTimeout `Prelude.seq` + DeepSeq.rnf __field__queueTimeout `Prelude.seq` + DeepSeq.rnf __field__headers `Prelude.seq` () + +instance Default.Default RpcOptions where + def + = RpcOptions Default.def Prelude.Nothing Default.def Default.def + Prelude.Nothing + +instance Hashable.Hashable RpcOptions where + hashWithSalt __salt + (RpcOptions _timeout _priority _chunkTimeout _queueTimeout + _headers) + = Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt (Hashable.hashWithSalt __salt _timeout) + _priority) + _chunkTimeout) + _queueTimeout) + (Prelude.fmap + (Prelude.map (\ (_k, _v) -> (_k, _v)) . Map.toAscList) + _headers) diff --git a/if/ApplicationException.thrift b/if/ApplicationException.thrift new file mode 100644 --- /dev/null +++ b/if/ApplicationException.thrift @@ -0,0 +1,31 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +namespace hs "Thrift.Protocol" + +enum ApplicationExceptionType { + Unknown = 0, + UnknownMethod = 1, + InvalidMessageType = 2, + WrongMethodType = 3, + BadSequenceId = 4, + MissingResult = 5, + InternalError = 6, + ProtocolError = 7, + InvalidTransform = 8, + InvalidProtocol = 9, + UnsupportedClientType = 10, + Loadshedding = 11, + Timeout = 12, + InjectedFailure = 13, +} + +exception ApplicationException { + 1: string message; + 2: ApplicationExceptionType type; +} diff --git a/if/RpcOptions.thrift b/if/RpcOptions.thrift new file mode 100644 --- /dev/null +++ b/if/RpcOptions.thrift @@ -0,0 +1,26 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +namespace cpp2 "thrift.protocol" +namespace hs "Thrift.Protocol" + +enum Priority { + HighImportant = 0, + High = 1, + Important = 2, + NormalPriority = 3, + BestEffort = 4, +} (hs.prefix = "") + +struct RpcOptions { + 1: i32 timeout; + 2: optional Priority priority; + 3: i32 chunkTimeout; + 4: i32 queueTimeout; + 5: optional map headers; +} (hs.prefix = "rpc_") diff --git a/test/BinaryParserTest.hs b/test/BinaryParserTest.hs new file mode 100644 --- /dev/null +++ b/test/BinaryParserTest.hs @@ -0,0 +1,86 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module BinaryParserTest where + +import Control.Monad (replicateM) +import Control.Applicative + +import Data.ByteString (ByteString) + +import Prelude hiding (takeWhile) + +import Test.HUnit +import TestRunner + +import Thrift.Binary.Parser + +expectParseSuccess :: (Eq a, Show a) => ByteString -> a -> Parser a -> IO () +expectParseSuccess inp expectedOut parser = + case parse parser inp of + Right value | value == expectedOut -> return () + Right wrongOut -> assertFailure $ + "expected " ++ show expectedOut ++ ", got " ++ show wrongOut + Left err -> assertFailure $ "parse error: " ++ err + +mkTestParseSuccess + :: (Eq a, Show a) => String -> ByteString -> a -> Parser a -> Test +mkTestParseSuccess name inp expectedOut parser = + TestLabel name $ TestCase $ expectParseSuccess inp expectedOut parser + +expectParseFailure :: ByteString -> Parser a -> IO () +expectParseFailure inp parser = + case parse parser inp of + Left _ -> return () + Right _ -> assertFailure "parsing should fail" + +mkTestParseFailure :: String -> ByteString -> Parser a -> Test +mkTestParseFailure name inp parser = + TestLabel name $ TestCase $ expectParseFailure inp parser + +testAnyWord8 :: Test +testAnyWord8 = mkTestParseSuccess "anyWord8" "\7" 7 anyWord8 + +testCombineParsers :: Test +testCombineParsers = + mkTestParseSuccess "combine parsers" "\3\1\2\3" [1,2,3] parseList + where + parseList = do + numElems <- anyWord8 + replicateM (fromIntegral numElems) anyWord8 + +testAlternative :: Test +testAlternative = TestLabel "backtracking" $ TestCase $ do + expectParseSuccess "\1" 1 parseWord8OrInt32 + expectParseSuccess "\0\0\0\1" 1 parseWord8OrInt32 + where + parseWord8OrInt32 :: Parser Int + parseWord8OrInt32 = + (word8 1 >> return 1) <|> (fromIntegral <$> getInt32be) + +testSkipSpaces :: Test +testSkipSpaces = + mkTestParseSuccess "skipSpaces" " \t\7" 7 (skipSpaces >> anyWord8) + +testTakeWhile :: Test +testTakeWhile = + mkTestParseSuccess "takeWhile" "abc\7" "abc" (takeWhile (/= 7)) + +main :: IO () +main = testRunner $ TestList + [ mkTestParseSuccess "getByteString" "abcd" "abc" (getByteString 3) + , testAnyWord8 + , mkTestParseFailure "anyWord8 not enough bytes" "" anyWord8 + , testCombineParsers + , testAlternative + , testSkipSpaces + , testTakeWhile + , mkTestParseSuccess "double" "10.2" (10.2 :: Double) double + , mkTestParseSuccess "double scientific" "1.0e-9" (1.0e-9 :: Double) double + , mkTestParseSuccess "double negative" "-1.0e-9" (-1.0e-9 :: Double) double + ] diff --git a/test/ChannelTest.hs b/test/ChannelTest.hs new file mode 100644 --- /dev/null +++ b/test/ChannelTest.hs @@ -0,0 +1,33 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module ChannelTest where + +import Control.Concurrent +import Control.Exception hiding (handle) +import Test.HUnit +import TestRunner + +import TestChannel +import Thrift.Channel + +clientTest :: Test +clientTest = TestLabel "client test" $ TestCase $ do + channel <- TestChannel <$> newEmptyMVar + bracket + (forkIO $ runTestServer channel $ \x -> return (x, Nothing, [])) + killThread $ + const $ do + let request = "this is my one request" + (handle, sendCob, recvCob) <- mkCallbacks Right + sendRequest channel (simpleRequest request) sendCob recvCob + Response{..} <- wait handle + assertEqual "request is same as response" request respMsg + +main :: IO () +main = testRunner clientTest diff --git a/test/ClientTest.hs b/test/ClientTest.hs new file mode 100644 --- /dev/null +++ b/test/ClientTest.hs @@ -0,0 +1,50 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module ClientTest where + +import Control.Concurrent +import Control.Exception hiding (DivideByZero) +import Control.Monad.Trans.Reader +import Data.Proxy +import TestRunner +import Test.HUnit hiding (State) + +import Thrift.Channel +import Thrift.Monad +import Thrift.Protocol +import Thrift.Protocol.Binary + +import Math.Calculator.Client + +import TestCommon +import TestChannel + +mkClientTestWith + :: String -> RpcOptions -> ThriftM Binary TestChannel Calculator () -> Test +mkClientTestWith label opts action = TestLabel label $ TestCase $ do + let proxy = Proxy :: Proxy Binary + channel <- TestChannel <$> newEmptyMVar + bracket (forkIO (runCalculatorServer proxy channel)) killThread $ const $ do + counter <- newCounter + let env = ThriftEnv proxy channel opts counter + runReaderT action env + +main :: IO () +main = testRunner . TestList $ + runChannelTests mkClientTestWith + [ addTest, divTest, putGetTest, putPutGetTest + , exceptionTest, optionsTest, unimplementedTest, multiTest ] + +-- Server Implementation ------------------------------------------------------- + +-- This is a library function +runCalculatorServer :: Protocol p => Proxy p -> TestChannel Calculator -> IO () +runCalculatorServer proxy ch = do + state <- initServerState + runServer proxy ch (processCommand state) (\_ _ -> []) diff --git a/test/JSONNullTest.hs b/test/JSONNullTest.hs new file mode 100644 --- /dev/null +++ b/test/JSONNullTest.hs @@ -0,0 +1,26 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module JSONNullTest (main) where + +import Test.HUnit +import TestRunner + +import Thrift.Protocol.JSON + +import HsTest.Types + +nullParsingTest :: Test +nullParsingTest = TestLabel "JSON with Null" $ TestCase $ + assertEqual "parse null" (Right $ Foo 999 0) $ deserializeJSON + "{\"bar\":999,\"baz\":null}" + +main :: IO () +main = testRunner $ TestList + [ nullParsingTest + ] diff --git a/test/JSONNumTest.hs b/test/JSONNumTest.hs new file mode 100644 --- /dev/null +++ b/test/JSONNumTest.hs @@ -0,0 +1,69 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE TypeApplications #-} +module JSONNumTest where + +import Thrift.Binary.Parser +import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Builder +import Data.Proxy +import Test.HUnit +import TestRunner + +import qualified Data.ByteString as B +import qualified Thrift.Protocol as Protocol +import Thrift.Protocol.JSON + +serializationTests :: [(String, Double, ByteString)] +serializationTests = + [ ( "Should handle a double appropiately" + , 10.1 + , "10.1" + ) + , ( "Should handle NaN appropiately" + , 0/0 + , "\"NaN\"" + ) + ] + +doubleGenTest :: (String, Double, ByteString) -> Test +doubleGenTest (testLabel, input, expected) = TestLabel testLabel $ TestCase $ + assertEqual "gen double" expected $ + genDouble input + +genDouble :: Double -> ByteString +genDouble = toLazyByteString . Protocol.genDouble @JSON Proxy + +parserTests :: [(String, B.ByteString, Double)] +parserTests = + [ ( "Should parse a double correctly" + , "10.1" + , 10.1 + ) + , ( "Should parse NaN correctly" + , "\"NaN\"" + , 0/0 + ) + ] + +parsingGenTest :: (String, B.ByteString, Double) -> Test +parsingGenTest (testLabel, input, expected) = TestLabel testLabel $ TestCase $ + case parseDouble input of + Right num -> if isNaN num + then assertBool "parse NaN" $ isNaN expected + else assertEqual "parse double" expected num + Left _ -> assertFailure "failed to parse" + +parseDouble :: B.ByteString -> Either String Double +parseDouble = parse (Protocol.parseDouble @JSON Proxy) + +main :: IO () +main = testRunner $ TestList $ + map doubleGenTest serializationTests ++ + map parsingGenTest parserTests diff --git a/test/JSONStringTest.hs b/test/JSONStringTest.hs new file mode 100644 --- /dev/null +++ b/test/JSONStringTest.hs @@ -0,0 +1,44 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE TypeApplications #-} +module JSONStringTest where + +import Thrift.Binary.Parser +import Data.ByteString (ByteString) +import Data.Proxy +import Data.Text (Text) +import Test.HUnit +import TestRunner + +import qualified Thrift.Protocol as Protocol +import Thrift.Protocol.JSON + +unicodeParsingTest :: Test +unicodeParsingTest = TestLabel "json string paring" $ TestCase $ + assertEqual "parse string" (Right "\27979\35797") $ + parseText "\"\\u00e6\\u00b5\\u008b\\u00e8\\u00af\\u0095\"" + +parseText :: ByteString -> Either String Text +parseText = parse (Protocol.parseText @JSON Proxy) + +expectParseError :: String -> ByteString -> Test +expectParseError name input = TestLabel name $ TestCase $ + case parseText input of + Left{} -> return () + Right{} -> assertFailure "Should fail" + +main :: IO () +main = testRunner $ TestList + [ unicodeParsingTest + , expectParseError "Incomplete String" "\"xxx" + , expectParseError "Incomplete Escape" "\"xxx\\\"" + , expectParseError "Incorrect Escape" "\"\\x\"" + , expectParseError "Incorrect Unicode" "\"\\uwxyz\"" + , expectParseError "Incomplete Unicode" "\"\\u00\"" + ] diff --git a/test/SocketChannelTest.hs b/test/SocketChannelTest.hs new file mode 100644 --- /dev/null +++ b/test/SocketChannelTest.hs @@ -0,0 +1,46 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module SocketChannelTest where + +import Network.Socket (maxListenQueue) +import TestRunner +import Test.HUnit hiding (State) + +import Thrift.Api +import Thrift.Channel +import Thrift.Channel.SocketChannel.Server +import Thrift.Protocol.Id + +import Math.Calculator.Client + +import TestCommon + +main :: IO () +main = testRunner . TestList $ + runChannelTests mkClientTestSockWith + [ addTest, divTest, putGetTest, putPutGetTest + , exceptionTest, unimplementedTest, multiTest ] + +-- Client utilities ------------------------------------------------------------ + +mkClientTestSock + :: String + -> Thrift Calculator () + -> Test +mkClientTestSock lbl = mkClientTestSockWith lbl defaultRpcOptions + +mkClientTestSockWith + :: String + -> RpcOptions + -> Thrift Calculator () + -> Test +mkClientTestSockWith lbl _opts action = TestLabel lbl $ TestCase $ do + state <- initServerState + withServer binaryProtocolId Nothing maxListenQueue (processCommand state) + (\_ _ -> []) action diff --git a/test/gen-hs2/HsTest/Types.hs b/test/gen-hs2/HsTest/Types.hs new file mode 100644 --- /dev/null +++ b/test/gen-hs2/HsTest/Types.hs @@ -0,0 +1,1420 @@ +----------------------------------------------------------------- +-- Autogenerated by Thrift +-- +-- DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING +-- @generated +----------------------------------------------------------------- +{-# LINE 8 "../lib/test/gen-hs2/HsTest/Types.hs" #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports#-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-record-updates#-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module HsTest.Types + (X(X, unX), Y, Z(Z, unZ), Foo(Foo, foo_bar, foo_baz), + TUnion(TUnion_EMPTY, TUnion_StringOption, TUnion_I64Option, + TUnion_FooOption), + TestStruct(TestStruct, testStruct_f_bool, testStruct_f_byte, + testStruct_f_double, testStruct_f_i16, testStruct_f_i32, + testStruct_f_i64, testStruct_f_float, testStruct_f_list, + testStruct_f_map, testStruct_f_text, testStruct_f_set, + testStruct_o_i32, testStruct_foo, testStruct_f_hash_map, + testStruct_f_newtype, testStruct_f_union, testStruct_f_string, + testStruct_f_binary, testStruct_f_optional_newtype, + testStruct_bool_map, testStruct_bool_list, testStruct_i64_vec, + testStruct_i64_svec, testStruct_binary_key, + testStruct_f_bytestring), + Number(Number_One, Number_Two, Number_Three, Number__UNKNOWN), + Perfect(Perfect_A, Perfect_B, Perfect_C, Perfect__UNKNOWN), + Void(Void__UNKNOWN), List_i64_1894, List_i64_7708, + Map_Number_i64_1522, String_1484, String_5858) + where +import qualified Control.DeepSeq as DeepSeq +import qualified Control.Exception as Exception +import qualified Control.Monad as Monad +import qualified Control.Monad.ST.Trans as ST +import qualified Control.Monad.Trans.Class as Trans +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import qualified Data.ByteString as ByteString +import qualified Data.Default as Default +import qualified Data.Function as Function +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Hashable as Hashable +import qualified Data.Int as Int +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import qualified Data.Ord as Ord +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Vector as Vector +import qualified Data.Vector.Storable as VectorStorable +import qualified GHC.Magic as GHC +import qualified Prelude as Prelude +import qualified Thrift.Binary.Parser as Parser +import qualified Thrift.CodegenTypesOnly as Thrift +import Control.Applicative ((<|>), (*>), (<*)) +import Data.Aeson ((.:), (.:?), (.=), (.!=)) +import Data.Aeson ((.:), (.=)) +import Data.Monoid ((<>)) +import Prelude ((.), (++), (>), (==)) +import Prelude ((.), (<$>), (<*>), (>>=), (==), (++)) +import Prelude ((.), (<$>), (<*>), (>>=), (==), (/=), (<), (++)) +{-# LINE 4 "if/hs_test_instances.hs" #-} +import qualified Test.QuickCheck as QuickCheck +{-# LINE 5 "if/hs_test_instances.hs" #-} +import qualified Data.Vector as Vector +{-# LINE 6 "if/hs_test_instances.hs" #-} +import qualified Data.Vector.Storable as VectorStorable +{-# LINE 7 "if/hs_test_instances.hs" #-} +import Prelude ((/=), ($)) +{-# LINE 76 "../lib/test/gen-hs2/HsTest/Types.hs" #-} + +newtype X = X{unX :: Int.Int64} + deriving (Prelude.Eq, Prelude.Show, DeepSeq.NFData, Prelude.Ord) + +instance Hashable.Hashable X where + hashWithSalt __salt (X __val) = Hashable.hashWithSalt __salt __val + +instance Aeson.ToJSON X where + toJSON (X __val) = Aeson.toJSON __val + +type Y = X + +newtype Z = Z{unZ :: Y} + deriving (Prelude.Eq, Prelude.Show, DeepSeq.NFData, Prelude.Ord) + +instance Hashable.Hashable Z where + hashWithSalt __salt (Z __val) = Hashable.hashWithSalt __salt __val + +instance Aeson.ToJSON Z where + toJSON (Z __val) = Aeson.toJSON (unX __val) + +data Foo = Foo{foo_bar :: Int.Int32, foo_baz :: Int.Int32} + deriving (Prelude.Eq, Prelude.Show, Prelude.Ord) + +instance Aeson.ToJSON Foo where + toJSON (Foo __field__bar __field__baz) + = Aeson.object + ("bar" .= __field__bar : "baz" .= __field__baz : Prelude.mempty) + +instance Thrift.ThriftStruct Foo where + buildStruct _proxy (Foo __field__bar __field__baz) + = Thrift.genStruct _proxy + (Thrift.genFieldPrim _proxy "bar" (Thrift.getI32Type _proxy) 5 0 + (Thrift.genI32Prim _proxy) + __field__bar + : + Thrift.genFieldPrim _proxy "baz" (Thrift.getI32Type _proxy) 1 5 + (Thrift.genI32Prim _proxy) + __field__baz + : []) + parseStruct _proxy + = ST.runSTT + (do Prelude.return () + __field__bar <- ST.newSTRef Default.def + __field__baz <- ST.newSTRef Default.def + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 5 | _type == + Thrift.getI32Type _proxy + -> + do !_val <- Trans.lift + (Thrift.parseI32 + _proxy) + ST.writeSTRef __field__bar + _val + 1 | _type == + Thrift.getI32Type _proxy + -> + do !_val <- Trans.lift + (Thrift.parseI32 + _proxy) + ST.writeSTRef __field__baz + _val + _ -> Trans.lift + (Thrift.parseSkip _proxy + _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do !__val__bar <- ST.readSTRef __field__bar + !__val__baz <- ST.readSTRef __field__baz + Prelude.pure (Foo __val__bar __val__baz) + _idMap = HashMap.fromList [("bar", 5), ("baz", 1)] + _parse 0) + +instance DeepSeq.NFData Foo where + rnf (Foo __field__bar __field__baz) + = DeepSeq.rnf __field__bar `Prelude.seq` + DeepSeq.rnf __field__baz `Prelude.seq` () + +instance Default.Default Foo where + def = Foo Default.def Default.def + +instance Hashable.Hashable Foo where + hashWithSalt __salt (Foo _bar _baz) + = Hashable.hashWithSalt (Hashable.hashWithSalt __salt _bar) _baz + +data TUnion = TUnion_StringOption Text.Text + | TUnion_I64Option Int.Int64 + | TUnion_FooOption Foo + | TUnion_EMPTY + deriving (Prelude.Eq, Prelude.Show, Prelude.Ord) + +instance Aeson.ToJSON TUnion where + toJSON (TUnion_StringOption __StringOption) + = Aeson.object ["StringOption" .= __StringOption] + toJSON (TUnion_I64Option __I64Option) + = Aeson.object ["I64Option" .= __I64Option] + toJSON (TUnion_FooOption __FooOption) + = Aeson.object ["FooOption" .= __FooOption] + toJSON TUnion_EMPTY = Aeson.object [] + +instance Thrift.ThriftStruct TUnion where + buildStruct _proxy (TUnion_StringOption __StringOption) + = Thrift.genStruct _proxy + [Thrift.genField _proxy "StringOption" + (Thrift.getStringType _proxy) + 1 + 0 + (Thrift.genText _proxy __StringOption)] + buildStruct _proxy (TUnion_I64Option __I64Option) + = Thrift.genStruct _proxy + [Thrift.genFieldPrim _proxy "I64Option" (Thrift.getI64Type _proxy) + 2 + 0 + (Thrift.genI64Prim _proxy) + __I64Option] + buildStruct _proxy (TUnion_FooOption __FooOption) + = Thrift.genStruct _proxy + [Thrift.genField _proxy "FooOption" (Thrift.getStructType _proxy) 3 + 0 + (Thrift.buildStruct _proxy __FooOption)] + buildStruct _proxy TUnion_EMPTY = Thrift.genStruct _proxy [] + parseStruct _proxy + = do _fieldBegin <- Thrift.parseFieldBegin _proxy 0 _idMap + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 1 | _type == Thrift.getStringType _proxy -> + do _val <- Thrift.parseText _proxy + Thrift.parseStop _proxy + Prelude.return + (TUnion_StringOption _val) + 2 | _type == Thrift.getI64Type _proxy -> + do _val <- Thrift.parseI64 _proxy + Thrift.parseStop _proxy + Prelude.return (TUnion_I64Option _val) + 3 | _type == Thrift.getStructType _proxy -> + do _val <- Thrift.parseStruct _proxy + Thrift.parseStop _proxy + Prelude.return (TUnion_FooOption _val) + _ -> do Thrift.parseSkip _proxy _type + Prelude.Nothing + Thrift.parseStop _proxy + Prelude.return TUnion_EMPTY + Thrift.FieldEnd -> Prelude.return TUnion_EMPTY + where + _idMap + = HashMap.fromList + [("StringOption", 1), ("I64Option", 2), ("FooOption", 3)] + +instance DeepSeq.NFData TUnion where + rnf (TUnion_StringOption __StringOption) + = DeepSeq.rnf __StringOption + rnf (TUnion_I64Option __I64Option) = DeepSeq.rnf __I64Option + rnf (TUnion_FooOption __FooOption) = DeepSeq.rnf __FooOption + rnf TUnion_EMPTY = () + +instance Default.Default TUnion where + def = TUnion_EMPTY + +instance Hashable.Hashable TUnion where + hashWithSalt __salt (TUnion_StringOption _StringOption) + = Hashable.hashWithSalt __salt + (Hashable.hashWithSalt 1 _StringOption) + hashWithSalt __salt (TUnion_I64Option _I64Option) + = Hashable.hashWithSalt __salt (Hashable.hashWithSalt 2 _I64Option) + hashWithSalt __salt (TUnion_FooOption _FooOption) + = Hashable.hashWithSalt __salt (Hashable.hashWithSalt 3 _FooOption) + hashWithSalt __salt TUnion_EMPTY + = Hashable.hashWithSalt __salt (0 :: Prelude.Int) + +data TestStruct = TestStruct{testStruct_f_bool :: Prelude.Bool, + testStruct_f_byte :: Int.Int8, + testStruct_f_double :: Prelude.Double, + testStruct_f_i16 :: Int.Int16, testStruct_f_i32 :: Int.Int32, + testStruct_f_i64 :: Int.Int64, testStruct_f_float :: Prelude.Float, + testStruct_f_list :: [Int.Int16], + testStruct_f_map :: Map.Map Int.Int16 Int.Int32, + testStruct_f_text :: Text.Text, + testStruct_f_set :: Set.Set Int.Int8, + testStruct_o_i32 :: Prelude.Maybe Int.Int32, testStruct_foo :: Foo, + testStruct_f_hash_map :: Map_Number_i64_1522, + testStruct_f_newtype :: Z, testStruct_f_union :: TUnion, + testStruct_f_string :: String_5858, + testStruct_f_binary :: ByteString.ByteString, + testStruct_f_optional_newtype :: Prelude.Maybe X, + testStruct_bool_map :: Map.Map Int.Int32 Prelude.Bool, + testStruct_bool_list :: [Prelude.Bool], + testStruct_i64_vec :: List_i64_7708, + testStruct_i64_svec :: List_i64_1894, + testStruct_binary_key :: Map.Map ByteString.ByteString Int.Int64, + testStruct_f_bytestring :: String_1484} + deriving (Prelude.Eq, Prelude.Show) + +instance Aeson.ToJSON TestStruct where + toJSON + (TestStruct __field__f_bool __field__f_byte __field__f_double + __field__f_i16 __field__f_i32 __field__f_i64 __field__f_float + __field__f_list __field__f_map __field__f_text __field__f_set + __field__o_i32 __field__foo __field__f_hash_map __field__f_newtype + __field__f_union __field__f_string __field__f_binary + __field__f_optional_newtype __field__bool_map __field__bool_list + __field__i64_vec __field__i64_svec __field__binary_key + __field__f_bytestring) + = Aeson.object + ("f_bool" .= __field__f_bool : + "f_byte" .= __field__f_byte : + "f_double" .= __field__f_double : + "f_i16" .= __field__f_i16 : + "f_i32" .= __field__f_i32 : + "f_i64" .= __field__f_i64 : + "f_float" .= __field__f_float : + "f_list" .= __field__f_list : + "f_map" .= Map.mapKeys Thrift.keyToStr __field__f_map : + "f_text" .= __field__f_text : + "f_set" .= __field__f_set : + Prelude.maybe Prelude.id ((:) . ("o_i32" .=)) __field__o_i32 + ("foo" .= __field__foo : + "f_hash_map" .= + Thrift.hmMapKeys Thrift.keyToStr __field__f_hash_map + : + "f_newtype" .= (unX . unZ) __field__f_newtype : + "f_union" .= __field__f_union : + "f_string" .= __field__f_string : + "f_binary" .= Thrift.encodeBase64Text __field__f_binary + : + Prelude.maybe Prelude.id + ((:) . ("f_optional_newtype" .=)) + (Prelude.fmap unX __field__f_optional_newtype) + ("bool_map" .= + Map.mapKeys Thrift.keyToStr __field__bool_map + : + "bool_list" .= __field__bool_list : + "i64_vec" .= __field__i64_vec : + "i64_svec" .= __field__i64_svec : + "binary_key" .= + Map.mapKeys Thrift.encodeBase64Text + __field__binary_key + : + "f_bytestring" .= + Text.decodeUtf8 __field__f_bytestring + : Prelude.mempty))) + +instance Thrift.ThriftStruct TestStruct where + buildStruct _proxy + (TestStruct __field__f_bool __field__f_byte __field__f_double + __field__f_i16 __field__f_i32 __field__f_i64 __field__f_float + __field__f_list __field__f_map __field__f_text __field__f_set + __field__o_i32 __field__foo __field__f_hash_map __field__f_newtype + __field__f_union __field__f_string __field__f_binary + __field__f_optional_newtype __field__bool_map __field__bool_list + __field__i64_vec __field__i64_svec __field__binary_key + __field__f_bytestring) + = Thrift.genStruct _proxy + (Thrift.genFieldBool _proxy "f_bool" 1 0 __field__f_bool : + Thrift.genFieldPrim _proxy "f_byte" (Thrift.getByteType _proxy) 2 1 + (Thrift.genBytePrim _proxy) + __field__f_byte + : + Thrift.genField _proxy "f_double" (Thrift.getDoubleType _proxy) 3 2 + (Thrift.genDouble _proxy __field__f_double) + : + Thrift.genFieldPrim _proxy "f_i16" (Thrift.getI16Type _proxy) 4 3 + (Thrift.genI16Prim _proxy) + __field__f_i16 + : + Thrift.genFieldPrim _proxy "f_i32" (Thrift.getI32Type _proxy) 5 4 + (Thrift.genI32Prim _proxy) + __field__f_i32 + : + Thrift.genFieldPrim _proxy "f_i64" (Thrift.getI64Type _proxy) 6 5 + (Thrift.genI64Prim _proxy) + __field__f_i64 + : + Thrift.genField _proxy "f_float" (Thrift.getFloatType _proxy) 7 6 + (Thrift.genFloat _proxy __field__f_float) + : + Thrift.genField _proxy "f_list" (Thrift.getListType _proxy) 8 7 + (Thrift.genListPrim _proxy (Thrift.getI16Type _proxy) + (Thrift.genI16Prim _proxy) + __field__f_list) + : + Thrift.genField _proxy "f_map" (Thrift.getMapType _proxy) 9 8 + ((Thrift.genMapPrim _proxy (Thrift.getI16Type _proxy) + (Thrift.getI32Type _proxy) + Prelude.False + (Thrift.genI16Prim _proxy) + (Thrift.genI32Prim _proxy) + . Map.toList) + __field__f_map) + : + Thrift.genField _proxy "f_text" (Thrift.getStringType _proxy) 10 9 + (Thrift.genText _proxy __field__f_text) + : + Thrift.genField _proxy "f_set" (Thrift.getSetType _proxy) 11 10 + ((Thrift.genListPrim _proxy (Thrift.getByteType _proxy) + (Thrift.genBytePrim _proxy) + . Set.toList) + __field__f_set) + : + let (__cereal__o_i32, __id__o_i32) + = case __field__o_i32 of + Prelude.Just _val -> ((:) + (Thrift.genFieldPrim _proxy "o_i32" + (Thrift.getI32Type _proxy) + 12 + 11 + (Thrift.genI32Prim _proxy) + _val), + 12) + Prelude.Nothing -> (Prelude.id, 11) + in + __cereal__o_i32 + (Thrift.genField _proxy "foo" (Thrift.getStructType _proxy) 99 + __id__o_i32 + (Thrift.buildStruct _proxy __field__foo) + : + Thrift.genField _proxy "f_hash_map" (Thrift.getMapType _proxy) + 13 + 99 + ((Thrift.genMap _proxy (Thrift.getI32Type _proxy) + (Thrift.getI64Type _proxy) + Prelude.False + (Thrift.genI32 _proxy . Prelude.fromIntegral . + Thrift.fromThriftEnum) + (Thrift.genI64 _proxy) + . HashMap.toList) + __field__f_hash_map) + : + Thrift.genField _proxy "f_newtype" + (Thrift.getI64Type _proxy) + 14 + 13 + ((Thrift.genI64 _proxy . unX . unZ) __field__f_newtype) + : + Thrift.genField _proxy "f_union" + (Thrift.getStructType _proxy) + 15 + 14 + (Thrift.buildStruct _proxy __field__f_union) + : + Thrift.genField _proxy "f_string" + (Thrift.getStringType _proxy) + 16 + 15 + ((Thrift.genText _proxy . Text.pack) + __field__f_string) + : + Thrift.genField _proxy "f_binary" + (Thrift.getStringType _proxy) + 17 + 16 + (Thrift.genBytes _proxy __field__f_binary) + : + let (__cereal__f_optional_newtype, + __id__f_optional_newtype) + = case __field__f_optional_newtype of + Prelude.Just _val -> ((:) + (Thrift.genField + _proxy + "f_optional_newtype" + (Thrift.getI64Type + _proxy) + 18 + 17 + ((Thrift.genI64 + _proxy + . unX) + _val)), + 18) + Prelude.Nothing -> (Prelude.id, 17) + in + __cereal__f_optional_newtype + (Thrift.genField _proxy "bool_map" + (Thrift.getMapType _proxy) + 19 + __id__f_optional_newtype + ((Thrift.genMapPrim _proxy + (Thrift.getI32Type _proxy) + (Thrift.getBoolType _proxy) + Prelude.False + (Thrift.genI32Prim _proxy) + (Thrift.genBoolPrim _proxy) + . Map.toList) + __field__bool_map) + : + Thrift.genField _proxy "bool_list" + (Thrift.getListType _proxy) + 20 + 19 + (Thrift.genListPrim _proxy + (Thrift.getBoolType _proxy) + (Thrift.genBoolPrim _proxy) + __field__bool_list) + : + Thrift.genField _proxy "i64_vec" + (Thrift.getListType _proxy) + 21 + 20 + ((Thrift.genListPrim _proxy + (Thrift.getI64Type _proxy) + (Thrift.genI64Prim _proxy) + . Vector.toList) + __field__i64_vec) + : + Thrift.genField _proxy "i64_svec" + (Thrift.getListType _proxy) + 22 + 21 + ((Thrift.genListPrim _proxy + (Thrift.getI64Type _proxy) + (Thrift.genI64Prim _proxy) + . VectorStorable.toList) + __field__i64_svec) + : + Thrift.genField _proxy "binary_key" + (Thrift.getMapType _proxy) + 23 + 22 + ((Thrift.genMap _proxy + (Thrift.getStringType _proxy) + (Thrift.getI64Type _proxy) + Prelude.True + (Thrift.genBytes _proxy) + (Thrift.genI64 _proxy) + . Map.toList) + __field__binary_key) + : + Thrift.genField _proxy "f_bytestring" + (Thrift.getStringType _proxy) + 24 + 23 + (Thrift.genByteString _proxy + __field__f_bytestring) + : []))) + parseStruct _proxy + = ST.runSTT + (do Prelude.return () + __field__f_bool <- ST.newSTRef Prelude.Nothing + __field__f_byte <- ST.newSTRef Default.def + __field__f_double <- ST.newSTRef Default.def + __field__f_i16 <- ST.newSTRef 5 + __field__f_i32 <- ST.newSTRef Default.def + __field__f_i64 <- ST.newSTRef Default.def + __field__f_float <- ST.newSTRef Default.def + __field__f_list <- ST.newSTRef Default.def + __field__f_map <- ST.newSTRef (Map.fromList [(1, 2)]) + __field__f_text <- ST.newSTRef "" + __field__f_set <- ST.newSTRef Default.def + __field__o_i32 <- ST.newSTRef Prelude.Nothing + __field__foo <- ST.newSTRef + (Default.def :: Foo){foo_bar = 1, foo_baz = 2} + __field__f_hash_map <- ST.newSTRef HashMap.empty + __field__f_newtype <- ST.newSTRef (Z (X Default.def)) + __field__f_union <- ST.newSTRef Default.def + __field__f_string <- ST.newSTRef Default.def + __field__f_binary <- ST.newSTRef "" + __field__f_optional_newtype <- ST.newSTRef Prelude.Nothing + __field__bool_map <- ST.newSTRef Default.def + __field__bool_list <- ST.newSTRef Default.def + __field__i64_vec <- ST.newSTRef Vector.empty + __field__i64_svec <- ST.newSTRef VectorStorable.empty + __field__binary_key <- ST.newSTRef Default.def + __field__f_bytestring <- ST.newSTRef Default.def + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 1 | _type == + Thrift.getBoolType _proxy + -> + do !_val <- Trans.lift + (Thrift.parseBoolF + _proxy + _bool) + ST.writeSTRef + __field__f_bool + (Prelude.Just _val) + 2 | _type == + Thrift.getByteType _proxy + -> + do !_val <- Trans.lift + (Thrift.parseByte + _proxy) + ST.writeSTRef + __field__f_byte + _val + 3 | _type == + Thrift.getDoubleType _proxy + -> + do !_val <- Trans.lift + (Thrift.parseDouble + _proxy) + ST.writeSTRef + __field__f_double + _val + 4 | _type == + Thrift.getI16Type _proxy + -> + do !_val <- Trans.lift + (Thrift.parseI16 + _proxy) + ST.writeSTRef __field__f_i16 + _val + 5 | _type == + Thrift.getI32Type _proxy + -> + do !_val <- Trans.lift + (Thrift.parseI32 + _proxy) + ST.writeSTRef __field__f_i32 + _val + 6 | _type == + Thrift.getI64Type _proxy + -> + do !_val <- Trans.lift + (Thrift.parseI64 + _proxy) + ST.writeSTRef __field__f_i64 + _val + 7 | _type == + Thrift.getFloatType _proxy + -> + do !_val <- Trans.lift + (Thrift.parseFloat + _proxy) + ST.writeSTRef + __field__f_float + _val + 8 | _type == + Thrift.getListType _proxy + -> + do !_val <- Trans.lift + (Prelude.snd <$> + Thrift.parseList + _proxy + (Thrift.parseI16 + _proxy)) + ST.writeSTRef + __field__f_list + _val + 9 | _type == + Thrift.getMapType _proxy + -> + do !_val <- Trans.lift + (Map.fromList <$> + Thrift.parseMap + _proxy + (Thrift.parseI16 + _proxy) + (Thrift.parseI32 + _proxy) + Prelude.False) + ST.writeSTRef __field__f_map + _val + 10 | _type == + Thrift.getStringType _proxy + -> + do !_val <- Trans.lift + (Thrift.parseText + _proxy) + ST.writeSTRef + __field__f_text + _val + 11 | _type == + Thrift.getSetType _proxy + -> + do !_val <- Trans.lift + (Set.fromList . + Prelude.snd + <$> + Thrift.parseList + _proxy + (Thrift.parseByte + _proxy)) + ST.writeSTRef + __field__f_set + _val + 12 | _type == + Thrift.getI32Type _proxy + -> + do !_val <- Trans.lift + (Thrift.parseI32 + _proxy) + ST.writeSTRef + __field__o_i32 + (Prelude.Just _val) + 99 | _type == + Thrift.getStructType _proxy + -> + do !_val <- Trans.lift + (Thrift.parseStruct + _proxy) + ST.writeSTRef __field__foo + _val + 13 | _type == + Thrift.getMapType _proxy + -> + do !_val <- Trans.lift + (HashMap.fromList + <$> + Thrift.parseMap + _proxy + (Thrift.parseEnum + _proxy + "Number") + (Thrift.parseI64 + _proxy) + Prelude.False) + ST.writeSTRef + __field__f_hash_map + _val + 14 | _type == + Thrift.getI64Type _proxy + -> + do !_val <- Trans.lift + (Prelude.fmap Z + (Prelude.fmap + X + (Thrift.parseI64 + _proxy))) + ST.writeSTRef + __field__f_newtype + _val + 15 | _type == + Thrift.getStructType _proxy + -> + do !_val <- Trans.lift + (Thrift.parseStruct + _proxy) + ST.writeSTRef + __field__f_union + _val + 16 | _type == + Thrift.getStringType _proxy + -> + do !_val <- Trans.lift + (Text.unpack <$> + Thrift.parseText + _proxy) + ST.writeSTRef + __field__f_string + _val + 17 | _type == + Thrift.getStringType _proxy + -> + do !_val <- Trans.lift + (Thrift.parseBytes + _proxy) + ST.writeSTRef + __field__f_binary + _val + 18 | _type == + Thrift.getI64Type _proxy + -> + do !_val <- Trans.lift + (Prelude.fmap X + (Thrift.parseI64 + _proxy)) + ST.writeSTRef + __field__f_optional_newtype + (Prelude.Just _val) + 19 | _type == + Thrift.getMapType _proxy + -> + do !_val <- Trans.lift + (Map.fromList + <$> + Thrift.parseMap + _proxy + (Thrift.parseI32 + _proxy) + (Thrift.parseBool + _proxy) + Prelude.False) + ST.writeSTRef + __field__bool_map + _val + 20 | _type == + Thrift.getListType _proxy + -> + do !_val <- Trans.lift + (Prelude.snd <$> + Thrift.parseList + _proxy + (Thrift.parseBool + _proxy)) + ST.writeSTRef + __field__bool_list + _val + 21 | _type == + Thrift.getListType _proxy + -> + do !_val <- Trans.lift + (Prelude.uncurry + Vector.fromListN + <$> + Thrift.parseList + _proxy + (Thrift.parseI64 + _proxy)) + ST.writeSTRef + __field__i64_vec + _val + 22 | _type == + Thrift.getListType _proxy + -> + do !_val <- Trans.lift + (Prelude.uncurry + VectorStorable.fromListN + <$> + Thrift.parseList + _proxy + (Thrift.parseI64 + _proxy)) + ST.writeSTRef + __field__i64_svec + _val + 23 | _type == + Thrift.getMapType _proxy + -> + do !_val <- Trans.lift + (Map.fromList + <$> + Thrift.parseMap + _proxy + (Thrift.parseBytes + _proxy) + (Thrift.parseI64 + _proxy) + Prelude.True) + ST.writeSTRef + __field__binary_key + _val + 24 | _type == + Thrift.getStringType _proxy + -> + do !_val <- Trans.lift + (Thrift.parseByteString + _proxy) + ST.writeSTRef + __field__f_bytestring + _val + _ -> Trans.lift + (Thrift.parseSkip _proxy + _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do !__maybe__f_bool <- ST.readSTRef + __field__f_bool + !__val__f_byte <- ST.readSTRef __field__f_byte + !__val__f_double <- ST.readSTRef __field__f_double + !__val__f_i16 <- ST.readSTRef __field__f_i16 + !__val__f_i32 <- ST.readSTRef __field__f_i32 + !__val__f_i64 <- ST.readSTRef __field__f_i64 + !__val__f_float <- ST.readSTRef __field__f_float + !__val__f_list <- ST.readSTRef __field__f_list + !__val__f_map <- ST.readSTRef __field__f_map + !__val__f_text <- ST.readSTRef __field__f_text + !__val__f_set <- ST.readSTRef __field__f_set + !__val__o_i32 <- ST.readSTRef __field__o_i32 + !__val__foo <- ST.readSTRef __field__foo + !__val__f_hash_map <- ST.readSTRef __field__f_hash_map + !__val__f_newtype <- ST.readSTRef __field__f_newtype + !__val__f_union <- ST.readSTRef __field__f_union + !__val__f_string <- ST.readSTRef __field__f_string + !__val__f_binary <- ST.readSTRef __field__f_binary + !__val__f_optional_newtype <- ST.readSTRef + __field__f_optional_newtype + !__val__bool_map <- ST.readSTRef __field__bool_map + !__val__bool_list <- ST.readSTRef __field__bool_list + !__val__i64_vec <- ST.readSTRef __field__i64_vec + !__val__i64_svec <- ST.readSTRef __field__i64_svec + !__val__binary_key <- ST.readSTRef __field__binary_key + !__val__f_bytestring <- ST.readSTRef + __field__f_bytestring + case __maybe__f_bool of + Prelude.Nothing -> Prelude.fail + "Error parsing type TestStruct: missing required field f_bool of type Prelude.Bool" + Prelude.Just __val__f_bool -> Prelude.pure + (TestStruct + __val__f_bool + __val__f_byte + __val__f_double + __val__f_i16 + __val__f_i32 + __val__f_i64 + __val__f_float + __val__f_list + __val__f_map + __val__f_text + __val__f_set + __val__o_i32 + __val__foo + __val__f_hash_map + __val__f_newtype + __val__f_union + __val__f_string + __val__f_binary + __val__f_optional_newtype + __val__bool_map + __val__bool_list + __val__i64_vec + __val__i64_svec + __val__binary_key + __val__f_bytestring) + _idMap + = HashMap.fromList + [("f_bool", 1), ("f_byte", 2), ("f_double", 3), ("f_i16", 4), + ("f_i32", 5), ("f_i64", 6), ("f_float", 7), ("f_list", 8), + ("f_map", 9), ("f_text", 10), ("f_set", 11), ("o_i32", 12), + ("foo", 99), ("f_hash_map", 13), ("f_newtype", 14), + ("f_union", 15), ("f_string", 16), ("f_binary", 17), + ("f_optional_newtype", 18), ("bool_map", 19), ("bool_list", 20), + ("i64_vec", 21), ("i64_svec", 22), ("binary_key", 23), + ("f_bytestring", 24)] + _parse 0) + +instance DeepSeq.NFData TestStruct where + rnf + (TestStruct __field__f_bool __field__f_byte __field__f_double + __field__f_i16 __field__f_i32 __field__f_i64 __field__f_float + __field__f_list __field__f_map __field__f_text __field__f_set + __field__o_i32 __field__foo __field__f_hash_map __field__f_newtype + __field__f_union __field__f_string __field__f_binary + __field__f_optional_newtype __field__bool_map __field__bool_list + __field__i64_vec __field__i64_svec __field__binary_key + __field__f_bytestring) + = DeepSeq.rnf __field__f_bool `Prelude.seq` + DeepSeq.rnf __field__f_byte `Prelude.seq` + DeepSeq.rnf __field__f_double `Prelude.seq` + DeepSeq.rnf __field__f_i16 `Prelude.seq` + DeepSeq.rnf __field__f_i32 `Prelude.seq` + DeepSeq.rnf __field__f_i64 `Prelude.seq` + DeepSeq.rnf __field__f_float `Prelude.seq` + DeepSeq.rnf __field__f_list `Prelude.seq` + DeepSeq.rnf __field__f_map `Prelude.seq` + DeepSeq.rnf __field__f_text `Prelude.seq` + DeepSeq.rnf __field__f_set `Prelude.seq` + DeepSeq.rnf __field__o_i32 `Prelude.seq` + DeepSeq.rnf __field__foo `Prelude.seq` + DeepSeq.rnf __field__f_hash_map `Prelude.seq` + DeepSeq.rnf __field__f_newtype `Prelude.seq` + DeepSeq.rnf __field__f_union `Prelude.seq` + DeepSeq.rnf __field__f_string `Prelude.seq` + DeepSeq.rnf __field__f_binary `Prelude.seq` + DeepSeq.rnf __field__f_optional_newtype `Prelude.seq` + DeepSeq.rnf __field__bool_map `Prelude.seq` + DeepSeq.rnf __field__bool_list `Prelude.seq` + DeepSeq.rnf __field__i64_vec `Prelude.seq` + DeepSeq.rnf __field__i64_svec `Prelude.seq` + DeepSeq.rnf __field__binary_key `Prelude.seq` + DeepSeq.rnf __field__f_bytestring + `Prelude.seq` () + +instance Default.Default TestStruct where + def + = TestStruct Prelude.False Default.def Default.def 5 Default.def + Default.def + Default.def + Default.def + (Map.fromList [(1, 2)]) + "" + Default.def + Prelude.Nothing + (Default.def :: Foo){foo_bar = 1, foo_baz = 2} + HashMap.empty + (Z (X Default.def)) + Default.def + Default.def + "" + Prelude.Nothing + Default.def + Default.def + Vector.empty + VectorStorable.empty + Default.def + Default.def + +instance Hashable.Hashable TestStruct where + hashWithSalt __salt + (TestStruct _f_bool _f_byte _f_double _f_i16 _f_i32 _f_i64 _f_float + _f_list _f_map _f_text _f_set _o_i32 _foo _f_hash_map _f_newtype + _f_union _f_string _f_binary _f_optional_newtype _bool_map + _bool_list _i64_vec _i64_svec _binary_key _f_bytestring) + = Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + (Hashable.hashWithSalt + __salt + _f_bool) + _f_byte) + _f_double) + _f_i16) + _f_i32) + _f_i64) + _f_float) + _f_list) + ((Prelude.map (\ (_k, _v) -> (_k, _v)) . + Map.toAscList) + _f_map)) + _f_text) + (Set.elems _f_set)) + _o_i32) + _foo) + ((List.sort . + Prelude.map (\ (_k, _v) -> (_k, _v)) . HashMap.toList) + _f_hash_map)) + _f_newtype) + _f_union) + _f_string) + _f_binary) + _f_optional_newtype) + ((Prelude.map (\ (_k, _v) -> (_k, _v)) . Map.toAscList) _bool_map)) + _bool_list) + (Vector.toList _i64_vec)) + (VectorStorable.toList _i64_svec)) + ((Prelude.map (\ (_k, _v) -> (_k, _v)) . Map.toAscList) + _binary_key)) + _f_bytestring + +instance Ord.Ord TestStruct where + compare __a __b + = case Ord.compare (testStruct_f_bool __a) (testStruct_f_bool __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare (testStruct_f_byte __a) (testStruct_f_byte __b) of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare (testStruct_f_double __a) (testStruct_f_double __b) of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare (testStruct_f_i16 __a) + (testStruct_f_i16 __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare (testStruct_f_i32 __a) + (testStruct_f_i32 __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare + (testStruct_f_i64 __a) + (testStruct_f_i64 __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare + (testStruct_f_float + __a) + (testStruct_f_float + __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare + (testStruct_f_list + __a) + (testStruct_f_list + __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare + (testStruct_f_map + __a) + (testStruct_f_map + __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare + (testStruct_f_text + __a) + (testStruct_f_text + __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare + (testStruct_f_set + __a) + (testStruct_f_set + __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare + (testStruct_o_i32 + __a) + (testStruct_o_i32 + __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare + (testStruct_foo + __a) + (testStruct_foo + __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare + ((List.sort + . + Prelude.map + (\ (_k, + _v) + -> + (_k, + _v)) + . + HashMap.toList) + (testStruct_f_hash_map + __a)) + ((List.sort + . + Prelude.map + (\ (_k, + _v) + -> + (_k, + _v)) + . + HashMap.toList) + (testStruct_f_hash_map + __b)) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare + (testStruct_f_newtype + __a) + (testStruct_f_newtype + __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare + (testStruct_f_union + __a) + (testStruct_f_union + __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare + (testStruct_f_string + __a) + (testStruct_f_string + __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare + (testStruct_f_binary + __a) + (testStruct_f_binary + __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare + (testStruct_f_optional_newtype + __a) + (testStruct_f_optional_newtype + __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare + (testStruct_bool_map + __a) + (testStruct_bool_map + __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare + (testStruct_bool_list + __a) + (testStruct_bool_list + __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare + (testStruct_i64_vec + __a) + (testStruct_i64_vec + __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare + (testStruct_i64_svec + __a) + (testStruct_i64_svec + __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> case + Ord.compare + (testStruct_binary_key + __a) + (testStruct_binary_key + __b) + of + Ord.LT -> Ord.LT + Ord.GT -> Ord.GT + Ord.EQ -> Ord.compare + (testStruct_f_bytestring + __a) + (testStruct_f_bytestring + __b) + +data Number = Number_One + | Number_Two + | Number_Three + | Number__UNKNOWN Prelude.Int + deriving (Prelude.Eq, Prelude.Show) + +instance Aeson.ToJSON Number where + toJSON = Aeson.toJSON . Thrift.fromThriftEnum + +instance DeepSeq.NFData Number where + rnf __Number = Prelude.seq __Number () + +instance Default.Default Number where + def = Number_One + +instance Hashable.Hashable Number where + hashWithSalt _salt _val + = Hashable.hashWithSalt _salt (Thrift.fromThriftEnum _val) + +instance Thrift.ThriftEnum Number where + toThriftEnum 1 = Number_One + toThriftEnum 2 = Number_Two + toThriftEnum 3 = Number_Three + toThriftEnum val = Number__UNKNOWN val + fromThriftEnum Number_One = 1 + fromThriftEnum Number_Two = 2 + fromThriftEnum Number_Three = 3 + fromThriftEnum (Number__UNKNOWN val) = val + allThriftEnumValues = [Number_One, Number_Two, Number_Three] + toThriftEnumEither 1 = Prelude.Right Number_One + toThriftEnumEither 2 = Prelude.Right Number_Two + toThriftEnumEither 3 = Prelude.Right Number_Three + toThriftEnumEither val + = Prelude.Left + ("toThriftEnumEither: not a valid identifier for enum Number: " ++ + Prelude.show val) + +instance Prelude.Ord Number where + compare = Function.on Prelude.compare Thrift.fromThriftEnum + +data Perfect = Perfect_A + | Perfect_B + | Perfect_C + | Perfect__UNKNOWN Prelude.Int + deriving (Prelude.Eq, Prelude.Show, Prelude.Ord) + +instance Aeson.ToJSON Perfect where + toJSON = Aeson.toJSON . Thrift.fromThriftEnum + +instance DeepSeq.NFData Perfect where + rnf __Perfect = Prelude.seq __Perfect () + +instance Default.Default Perfect where + def = Perfect_A + +instance Hashable.Hashable Perfect where + hashWithSalt _salt _val + = Hashable.hashWithSalt _salt (Thrift.fromThriftEnum _val) + +instance Thrift.ThriftEnum Perfect where + toThriftEnum 0 = Perfect_A + toThriftEnum 1 = Perfect_B + toThriftEnum 2 = Perfect_C + toThriftEnum val = Perfect__UNKNOWN val + fromThriftEnum Perfect_A = 0 + fromThriftEnum Perfect_B = 1 + fromThriftEnum Perfect_C = 2 + fromThriftEnum (Perfect__UNKNOWN val) = val + allThriftEnumValues = [Perfect_A, Perfect_B, Perfect_C] + toThriftEnumEither 0 = Prelude.Right Perfect_A + toThriftEnumEither 1 = Prelude.Right Perfect_B + toThriftEnumEither 2 = Prelude.Right Perfect_C + toThriftEnumEither val + = Prelude.Left + ("toThriftEnumEither: not a valid identifier for enum Perfect: " ++ + Prelude.show val) + +data Void = Void__UNKNOWN Prelude.Int + deriving (Prelude.Eq, Prelude.Show, Prelude.Ord) + +instance Aeson.ToJSON Void where + toJSON = Aeson.toJSON . Thrift.fromThriftEnum + +instance DeepSeq.NFData Void where + rnf __Void = Prelude.seq __Void () + +instance Default.Default Void where + def + = Exception.throw + (Thrift.ProtocolException "def: enum Void has no constructors") + +instance Hashable.Hashable Void where + hashWithSalt _salt _val + = Hashable.hashWithSalt _salt (Thrift.fromThriftEnum _val) + +instance Thrift.ThriftEnum Void where + toThriftEnum val = Void__UNKNOWN val + fromThriftEnum (Void__UNKNOWN val) = val + allThriftEnumValues = [] + toThriftEnumEither val + = Prelude.Left + ("toThriftEnumEither: not a valid identifier for enum Void: " ++ + Prelude.show val) + +type List_i64_1894 = VectorStorable.Vector Int.Int64 + +type List_i64_7708 = Vector.Vector Int.Int64 + +type Map_Number_i64_1522 = HashMap.HashMap Number Int.Int64 + +type String_1484 = ByteString.ByteString + +type String_5858 = Prelude.String +{-# LINE 9 "if/hs_test_instances.hs" #-} +instance QuickCheck.Arbitrary Foo where + arbitrary = Foo <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary +{-# LINE 12 "if/hs_test_instances.hs" #-} +instance QuickCheck.Arbitrary TestStruct where + arbitrary + = TestStruct <$> QuickCheck.arbitrary <*> QuickCheck.arbitrary <*> + QuickCheck.arbitrary + <*> QuickCheck.arbitrary + <*> QuickCheck.arbitrary + <*> QuickCheck.arbitrary + <*> QuickCheck.arbitrary + <*> QuickCheck.arbitrary + <*> (Map.fromList <$> QuickCheck.arbitrary) + <*> arbitraryText + <*> (Set.fromList <$> QuickCheck.arbitrary) + <*> QuickCheck.arbitrary + <*> QuickCheck.arbitrary + <*> (HashMap.fromList <$> QuickCheck.arbitrary) + <*> ((Z . X) <$> QuickCheck.arbitrary) + <*> QuickCheck.arbitrary + <*> arbitraryString + <*> arbitraryBS + <*> (Prelude.fmap X <$> QuickCheck.arbitrary) + <*> QuickCheck.arbitrary + <*> QuickCheck.arbitrary + <*> (Vector.fromList <$> QuickCheck.arbitrary) + <*> (VectorStorable.fromList <$> QuickCheck.arbitrary) + <*> arbitraryBSMap + <*> (Text.encodeUtf8 <$> arbitraryText) +{-# LINE 40 "if/hs_test_instances.hs" #-} +instance QuickCheck.Arbitrary Number where + arbitrary + = QuickCheck.oneof $ + Prelude.map Prelude.pure [Number_One, Number_Two, Number_Three] +{-# LINE 44 "if/hs_test_instances.hs" #-} +instance QuickCheck.Arbitrary TUnion where + arbitrary + = QuickCheck.oneof + [TUnion_StringOption <$> arbitraryText, + TUnion_I64Option <$> QuickCheck.arbitrary, + TUnion_FooOption <$> QuickCheck.arbitrary, + Prelude.pure TUnion_EMPTY] +{-# LINE 52 "if/hs_test_instances.hs" #-} +arbitraryString :: QuickCheck.Gen Prelude.String +{-# LINE 53 "if/hs_test_instances.hs" #-} +arbitraryString + = Prelude.filter (/= '\NUL') <$> QuickCheck.arbitrary +{-# LINE 55 "if/hs_test_instances.hs" #-} +arbitraryText :: QuickCheck.Gen Text.Text +{-# LINE 56 "if/hs_test_instances.hs" #-} +arbitraryText = Text.pack <$> arbitraryString +{-# LINE 58 "if/hs_test_instances.hs" #-} +arbitraryBS :: QuickCheck.Gen ByteString.ByteString +{-# LINE 59 "if/hs_test_instances.hs" #-} +arbitraryBS = ByteString.pack <$> QuickCheck.arbitrary +{-# LINE 61 "if/hs_test_instances.hs" #-} +arbitraryBSMap :: + QuickCheck.Arbitrary a => + QuickCheck.Gen (Map.Map ByteString.ByteString a) +{-# LINE 63 "if/hs_test_instances.hs" #-} +arbitraryBSMap + = Map.fromList . Prelude.map (\ (k, v) -> (ByteString.pack k, v)) + <$> QuickCheck.arbitrary diff --git a/test/gen-hs2/Math/Adder/Client.hs b/test/gen-hs2/Math/Adder/Client.hs new file mode 100644 --- /dev/null +++ b/test/gen-hs2/Math/Adder/Client.hs @@ -0,0 +1,153 @@ +----------------------------------------------------------------- +-- Autogenerated by Thrift +-- +-- DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING +-- @generated +----------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports#-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-record-updates#-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Math.Adder.Client + (Adder, add, addIO, send_add, _build_add, recv_add, _parse_add) + where +import qualified Control.Arrow as Arrow +import qualified Control.Concurrent as Concurrent +import qualified Control.Exception as Exception +import qualified Control.Monad as Monad +import qualified Control.Monad.Trans.Class as Trans +import qualified Control.Monad.Trans.Reader as Reader +import qualified Data.ByteString.Builder as ByteString +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Int as Int +import qualified Data.List as List +import qualified Data.Proxy as Proxy +import qualified Prelude as Prelude +import qualified Thrift.Binary.Parser as Parser +import qualified Thrift.Codegen as Thrift +import qualified Thrift.Protocol.ApplicationException.Types + as Thrift +import Data.Monoid ((<>)) +import Prelude ((==), (=<<), (>>=), (<$>), (.)) +import Math.Types + +data Adder + +add :: + (Thrift.Protocol p, Thrift.ClientChannel c, (Thrift.<:) s Adder) => + Prelude.Int -> Prelude.Int -> Thrift.ThriftM p c s Prelude.Int +add __field__x __field__y + = do Thrift.ThriftEnv _proxy _channel _opts _counter <- Reader.ask + Trans.lift + (addIO _proxy _channel _counter _opts __field__x __field__y) + +addIO :: + (Thrift.Protocol p, Thrift.ClientChannel c, (Thrift.<:) s Adder) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.RpcOptions -> + Prelude.Int -> Prelude.Int -> Prelude.IO Prelude.Int +addIO _proxy _channel _counter _opts __field__x __field__y + = do (_handle, _sendCob, _recvCob) <- Thrift.mkCallbacks + (recv_add _proxy) + send_add _proxy _channel _counter _sendCob _recvCob _opts + __field__x + __field__y + Thrift.wait _handle + +send_add :: + (Thrift.Protocol p, Thrift.ClientChannel c, (Thrift.<:) s Adder) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.SendCallback -> + Thrift.RecvCallback -> + Thrift.RpcOptions -> Prelude.Int -> Prelude.Int -> Prelude.IO () +send_add _proxy _channel _counter _sendCob _recvCob _rpcOpts + __field__x __field__y + = do _seqNum <- _counter + let + _callMsg + = LBS.toStrict + (ByteString.toLazyByteString + (_build_add _proxy _seqNum __field__x __field__y)) + Thrift.sendRequest _channel + (Thrift.Request _callMsg + (Thrift.setRpcPriority _rpcOpts Thrift.NormalPriority)) + _sendCob + _recvCob + +recv_add :: + (Thrift.Protocol p) => + Proxy.Proxy p -> + Thrift.Response -> + Prelude.Either Exception.SomeException Prelude.Int +recv_add _proxy (Thrift.Response _response _) + = Monad.join + (Arrow.left (Exception.SomeException . Thrift.ProtocolException) + (Parser.parse (_parse_add _proxy) _response)) + +_build_add :: + Thrift.Protocol p => + Proxy.Proxy p -> + Int.Int32 -> Prelude.Int -> Prelude.Int -> ByteString.Builder +_build_add _proxy _seqNum __field__x __field__y + = Thrift.genMsgBegin _proxy "add" 1 _seqNum <> + Thrift.genStruct _proxy + (Thrift.genField _proxy "x" (Thrift.getI64Type _proxy) 1 0 + ((Thrift.genI64 _proxy . Prelude.fromIntegral) __field__x) + : + Thrift.genField _proxy "y" (Thrift.getI64Type _proxy) 2 1 + ((Thrift.genI64 _proxy . Prelude.fromIntegral) __field__y) + : []) + <> Thrift.genMsgEnd _proxy + +_parse_add :: + Thrift.Protocol p => + Proxy.Proxy p -> + Parser.Parser (Prelude.Either Exception.SomeException Prelude.Int) +_parse_add _proxy + = do Thrift.MsgBegin _name _msgTy _ <- Thrift.parseMsgBegin _proxy + _result <- case _msgTy of + 1 -> Prelude.fail "add: expected reply but got function call" + 2 | _name == "add" -> + do let + _idMap = HashMap.fromList [("add_success", 0)] + _fieldBegin <- Thrift.parseFieldBegin _proxy 0 _idMap + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 0 | _type == + Thrift.getI64Type + _proxy + -> + Prelude.fmap + Prelude.Right + (Prelude.fromIntegral + <$> + Thrift.parseI64 + _proxy) + _ -> Prelude.fail + (Prelude.unwords + ["unrecognized exception, type:", + Prelude.show + _type, + "field id:", + Prelude.show _id]) + Thrift.FieldEnd -> Prelude.fail "no response" + | Prelude.otherwise -> Prelude.fail "reply function does not match" + 3 -> Prelude.fmap (Prelude.Left . Exception.SomeException) + (Thrift.parseStruct _proxy :: + Parser.Parser Thrift.ApplicationException) + 4 -> Prelude.fail + "add: expected reply but got oneway function call" + _ -> Prelude.fail "add: invalid message type" + Thrift.parseMsgEnd _proxy + Prelude.return _result diff --git a/test/gen-hs2/Math/Adder/Service.hs b/test/gen-hs2/Math/Adder/Service.hs new file mode 100644 --- /dev/null +++ b/test/gen-hs2/Math/Adder/Service.hs @@ -0,0 +1,131 @@ +----------------------------------------------------------------- +-- Autogenerated by Thrift +-- +-- DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING +-- @generated +----------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports#-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-record-updates#-} +{-# LANGUAGE GADTs #-} +module Math.Adder.Service + (AdderCommand(..), reqName', reqParser', respWriter', methodsInfo') + where +import qualified Control.Exception as Exception +import qualified Control.Monad.ST.Trans as ST +import qualified Control.Monad.Trans.Class as Trans +import qualified Data.ByteString.Builder as Builder +import qualified Data.Default as Default +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Int as Int +import qualified Data.Map.Strict as Map +import qualified Data.Proxy as Proxy +import qualified Data.Text as Text +import qualified Math.Types as Types +import qualified Prelude as Prelude +import qualified Thrift.Binary.Parser as Parser +import qualified Thrift.Codegen as Thrift +import qualified Thrift.Processor as Thrift +import qualified Thrift.Protocol.ApplicationException.Types + as Thrift +import Control.Applicative ((<*), (*>)) +import Data.Monoid ((<>)) +import Prelude ((<$>), (<*>), (++), (.), (==)) + +data AdderCommand a where + Add :: Prelude.Int -> Prelude.Int -> AdderCommand Prelude.Int + +instance Thrift.Processor AdderCommand where + reqName = reqName' + reqParser = reqParser' + respWriter = respWriter' + methodsInfo _ = methodsInfo' + +reqName' :: AdderCommand a -> Text.Text +reqName' (Add __field__x __field__y) = "add" + +reqParser' :: + Thrift.Protocol p => + Proxy.Proxy p -> + Text.Text -> Parser.Parser (Thrift.Some AdderCommand) +reqParser' _proxy "add" + = ST.runSTT + (do Prelude.return () + __field__x <- ST.newSTRef Default.def + __field__y <- ST.newSTRef Default.def + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 1 | _type == Thrift.getI64Type _proxy + -> + do !_val <- Trans.lift + (Prelude.fromIntegral + <$> + Thrift.parseI64 + _proxy) + ST.writeSTRef __field__x _val + 2 | _type == Thrift.getI64Type _proxy + -> + do !_val <- Trans.lift + (Prelude.fromIntegral + <$> + Thrift.parseI64 + _proxy) + ST.writeSTRef __field__y _val + _ -> Trans.lift + (Thrift.parseSkip _proxy _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do !__val__x <- ST.readSTRef __field__x + !__val__y <- ST.readSTRef __field__y + Prelude.pure (Thrift.Some (Add __val__x __val__y)) + _idMap = HashMap.fromList [("x", 1), ("y", 2)] + _parse 0) +reqParser' _ funName + = Prelude.errorWithoutStackTrace + ("unknown function call: " ++ Text.unpack funName) + +respWriter' :: + Thrift.Protocol p => + Proxy.Proxy p -> + Int.Int32 -> + AdderCommand a -> + Prelude.Either Exception.SomeException a -> + (Builder.Builder, + Prelude.Maybe (Exception.SomeException, Thrift.Blame)) +respWriter' _proxy _seqNum Add{} _r + = (Thrift.genMsgBegin _proxy "add" _msgType _seqNum <> _msgBody <> + Thrift.genMsgEnd _proxy, + _msgException) + where + (_msgType, _msgBody, _msgException) + = case _r of + Prelude.Left _ex | Prelude.Just + _e@Thrift.ApplicationException{} <- Exception.fromException _ex + -> + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (_ex, Thrift.ServerError)) + | Prelude.otherwise -> + let _e + = Thrift.ApplicationException (Text.pack (Prelude.show _ex)) + Thrift.ApplicationExceptionType_InternalError + in + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (Exception.toException _e, Thrift.ServerError)) + Prelude.Right _result -> (2, + Thrift.genStruct _proxy + [Thrift.genField _proxy "" (Thrift.getI64Type _proxy) 0 0 + ((Thrift.genI64 _proxy . Prelude.fromIntegral) _result)], + Prelude.Nothing) + +methodsInfo' :: Map.Map Text.Text Thrift.MethodInfo +methodsInfo' + = Map.fromList + [("add", Thrift.MethodInfo Thrift.NormalPriority Prelude.False)] diff --git a/test/gen-hs2/Math/Calculator/Client.hs b/test/gen-hs2/Math/Calculator/Client.hs new file mode 100644 --- /dev/null +++ b/test/gen-hs2/Math/Calculator/Client.hs @@ -0,0 +1,598 @@ +----------------------------------------------------------------- +-- Autogenerated by Thrift +-- +-- DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING +-- @generated +----------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports#-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-record-updates#-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Math.Calculator.Client + (Calculator, divide, divideIO, send_divide, _build_divide, + recv_divide, _parse_divide, quotRem, quotRemIO, send_quotRem, + _build_quotRem, recv_quotRem, _parse_quotRem, put, putIO, send_put, + _build_put, putMany, putManyIO, send_putMany, _build_putMany, get, + getIO, send_get, _build_get, recv_get, _parse_get, unimplemented, + unimplementedIO, send_unimplemented, _build_unimplemented, + recv_unimplemented, _parse_unimplemented) + where +import qualified Control.Arrow as Arrow +import qualified Control.Concurrent as Concurrent +import qualified Control.Exception as Exception +import qualified Control.Monad as Monad +import qualified Control.Monad.Trans.Class as Trans +import qualified Control.Monad.Trans.Reader as Reader +import qualified Data.ByteString.Builder as ByteString +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Int as Int +import qualified Data.List as List +import qualified Data.Proxy as Proxy +import qualified Math.Adder.Client as Adder +import qualified Prelude as Prelude +import qualified Thrift.Binary.Parser as Parser +import qualified Thrift.Codegen as Thrift +import qualified Thrift.Protocol.ApplicationException.Types + as Thrift +import Data.Monoid ((<>)) +import Prelude ((==), (=<<), (>>=), (<$>), (.)) +import Math.Types + +data Calculator + +type instance Thrift.Super Calculator = Adder.Adder + +divide :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Prelude.Double -> + Prelude.Double -> Thrift.ThriftM p c s Prelude.Double +divide __field__dividend __field__divisor + = do Thrift.ThriftEnv _proxy _channel _opts _counter <- Reader.ask + Trans.lift + (divideIO _proxy _channel _counter _opts __field__dividend + __field__divisor) + +divideIO :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.RpcOptions -> + Prelude.Double -> Prelude.Double -> Prelude.IO Prelude.Double +divideIO _proxy _channel _counter _opts __field__dividend + __field__divisor + = do (_handle, _sendCob, _recvCob) <- Thrift.mkCallbacks + (recv_divide _proxy) + send_divide _proxy _channel _counter _sendCob _recvCob _opts + __field__dividend + __field__divisor + Thrift.wait _handle + +send_divide :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.SendCallback -> + Thrift.RecvCallback -> + Thrift.RpcOptions -> + Prelude.Double -> Prelude.Double -> Prelude.IO () +send_divide _proxy _channel _counter _sendCob _recvCob _rpcOpts + __field__dividend __field__divisor + = do _seqNum <- _counter + let + _callMsg + = LBS.toStrict + (ByteString.toLazyByteString + (_build_divide _proxy _seqNum __field__dividend __field__divisor)) + Thrift.sendRequest _channel + (Thrift.Request _callMsg + (Thrift.setRpcPriority _rpcOpts Thrift.NormalPriority)) + _sendCob + _recvCob + +recv_divide :: + (Thrift.Protocol p) => + Proxy.Proxy p -> + Thrift.Response -> + Prelude.Either Exception.SomeException Prelude.Double +recv_divide _proxy (Thrift.Response _response _) + = Monad.join + (Arrow.left (Exception.SomeException . Thrift.ProtocolException) + (Parser.parse (_parse_divide _proxy) _response)) + +_build_divide :: + Thrift.Protocol p => + Proxy.Proxy p -> + Int.Int32 -> Prelude.Double -> Prelude.Double -> ByteString.Builder +_build_divide _proxy _seqNum __field__dividend __field__divisor + = Thrift.genMsgBegin _proxy "divide" 1 _seqNum <> + Thrift.genStruct _proxy + (Thrift.genField _proxy "dividend" (Thrift.getDoubleType _proxy) 1 + 0 + (Thrift.genDouble _proxy __field__dividend) + : + Thrift.genField _proxy "divisor" (Thrift.getDoubleType _proxy) 2 1 + (Thrift.genDouble _proxy __field__divisor) + : []) + <> Thrift.genMsgEnd _proxy + +_parse_divide :: + Thrift.Protocol p => + Proxy.Proxy p -> + Parser.Parser + (Prelude.Either Exception.SomeException Prelude.Double) +_parse_divide _proxy + = do Thrift.MsgBegin _name _msgTy _ <- Thrift.parseMsgBegin _proxy + _result <- case _msgTy of + 1 -> Prelude.fail "divide: expected reply but got function call" + 2 | _name == "divide" -> + do let + _idMap + = HashMap.fromList [("divide_success", 0), ("divisionError", 1)] + _fieldBegin <- Thrift.parseFieldBegin _proxy 0 _idMap + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 0 | _type == + Thrift.getDoubleType + _proxy + -> + Prelude.fmap + Prelude.Right + (Thrift.parseDouble + _proxy) + 1 | _type == + Thrift.getStructType + _proxy + -> + Prelude.fmap + (Prelude.Left . + Exception.SomeException) + (Thrift.parseStruct + _proxy + :: + Parser.Parser + DivideByZero) + _ -> Prelude.fail + (Prelude.unwords + ["unrecognized exception, type:", + Prelude.show + _type, + "field id:", + Prelude.show _id]) + Thrift.FieldEnd -> Prelude.fail "no response" + | Prelude.otherwise -> Prelude.fail "reply function does not match" + 3 -> Prelude.fmap (Prelude.Left . Exception.SomeException) + (Thrift.parseStruct _proxy :: + Parser.Parser Thrift.ApplicationException) + 4 -> Prelude.fail + "divide: expected reply but got oneway function call" + _ -> Prelude.fail "divide: invalid message type" + Thrift.parseMsgEnd _proxy + Prelude.return _result + +quotRem :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Prelude.Int -> Prelude.Int -> Thrift.ThriftM p c s QuotRemResponse +quotRem __field__dividend __field__divisor + = do Thrift.ThriftEnv _proxy _channel _opts _counter <- Reader.ask + Trans.lift + (quotRemIO _proxy _channel _counter _opts __field__dividend + __field__divisor) + +quotRemIO :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.RpcOptions -> + Prelude.Int -> Prelude.Int -> Prelude.IO QuotRemResponse +quotRemIO _proxy _channel _counter _opts __field__dividend + __field__divisor + = do (_handle, _sendCob, _recvCob) <- Thrift.mkCallbacks + (recv_quotRem _proxy) + send_quotRem _proxy _channel _counter _sendCob _recvCob _opts + __field__dividend + __field__divisor + Thrift.wait _handle + +send_quotRem :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.SendCallback -> + Thrift.RecvCallback -> + Thrift.RpcOptions -> Prelude.Int -> Prelude.Int -> Prelude.IO () +send_quotRem _proxy _channel _counter _sendCob _recvCob _rpcOpts + __field__dividend __field__divisor + = do _seqNum <- _counter + let + _callMsg + = LBS.toStrict + (ByteString.toLazyByteString + (_build_quotRem _proxy _seqNum __field__dividend __field__divisor)) + Thrift.sendRequest _channel + (Thrift.Request _callMsg + (Thrift.setRpcPriority _rpcOpts Thrift.NormalPriority)) + _sendCob + _recvCob + +recv_quotRem :: + (Thrift.Protocol p) => + Proxy.Proxy p -> + Thrift.Response -> + Prelude.Either Exception.SomeException QuotRemResponse +recv_quotRem _proxy (Thrift.Response _response _) + = Monad.join + (Arrow.left (Exception.SomeException . Thrift.ProtocolException) + (Parser.parse (_parse_quotRem _proxy) _response)) + +_build_quotRem :: + Thrift.Protocol p => + Proxy.Proxy p -> + Int.Int32 -> Prelude.Int -> Prelude.Int -> ByteString.Builder +_build_quotRem _proxy _seqNum __field__dividend __field__divisor + = Thrift.genMsgBegin _proxy "quotRem" 1 _seqNum <> + Thrift.genStruct _proxy + (Thrift.genField _proxy "dividend" (Thrift.getI64Type _proxy) 1 0 + ((Thrift.genI64 _proxy . Prelude.fromIntegral) __field__dividend) + : + Thrift.genField _proxy "divisor" (Thrift.getI64Type _proxy) 2 1 + ((Thrift.genI64 _proxy . Prelude.fromIntegral) __field__divisor) + : []) + <> Thrift.genMsgEnd _proxy + +_parse_quotRem :: + Thrift.Protocol p => + Proxy.Proxy p -> + Parser.Parser + (Prelude.Either Exception.SomeException QuotRemResponse) +_parse_quotRem _proxy + = do Thrift.MsgBegin _name _msgTy _ <- Thrift.parseMsgBegin _proxy + _result <- case _msgTy of + 1 -> Prelude.fail "quotRem: expected reply but got function call" + 2 | _name == "quotRem" -> + do let + _idMap = HashMap.fromList [("quotRem_success", 0)] + _fieldBegin <- Thrift.parseFieldBegin _proxy 0 _idMap + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 0 | _type == + Thrift.getStructType + _proxy + -> + Prelude.fmap + Prelude.Right + (Thrift.parseStruct + _proxy) + _ -> Prelude.fail + (Prelude.unwords + ["unrecognized exception, type:", + Prelude.show + _type, + "field id:", + Prelude.show _id]) + Thrift.FieldEnd -> Prelude.fail "no response" + | Prelude.otherwise -> Prelude.fail "reply function does not match" + 3 -> Prelude.fmap (Prelude.Left . Exception.SomeException) + (Thrift.parseStruct _proxy :: + Parser.Parser Thrift.ApplicationException) + 4 -> Prelude.fail + "quotRem: expected reply but got oneway function call" + _ -> Prelude.fail "quotRem: invalid message type" + Thrift.parseMsgEnd _proxy + Prelude.return _result + +put :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Prelude.Int -> Thrift.ThriftM p c s () +put __field__val + = do Thrift.ThriftEnv _proxy _channel _opts _counter <- Reader.ask + Trans.lift (putIO _proxy _channel _counter _opts __field__val) + +putIO :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> Thrift.RpcOptions -> Prelude.Int -> Prelude.IO () +putIO _proxy _channel _counter _opts __field__val + = do _handle <- Concurrent.newEmptyMVar + send_put _proxy _channel _counter (Concurrent.putMVar _handle) + _opts + __field__val + Concurrent.takeMVar _handle >>= + Prelude.maybe (Prelude.return ()) Exception.throw + +send_put :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.SendCallback -> + Thrift.RpcOptions -> Prelude.Int -> Prelude.IO () +send_put _proxy _channel _counter _sendCob _rpcOpts __field__val + = do _seqNum <- _counter + let + _callMsg + = LBS.toStrict + (ByteString.toLazyByteString + (_build_put _proxy _seqNum __field__val)) + Thrift.sendOnewayRequest _channel + (Thrift.Request _callMsg + (Thrift.setRpcPriority _rpcOpts Thrift.NormalPriority)) + _sendCob + +_build_put :: + Thrift.Protocol p => + Proxy.Proxy p -> Int.Int32 -> Prelude.Int -> ByteString.Builder +_build_put _proxy _seqNum __field__val + = Thrift.genMsgBegin _proxy "put" 1 _seqNum <> + Thrift.genStruct _proxy + (Thrift.genField _proxy "val" (Thrift.getI64Type _proxy) 1 0 + ((Thrift.genI64 _proxy . Prelude.fromIntegral) __field__val) + : []) + <> Thrift.genMsgEnd _proxy + +putMany :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + [Prelude.Int] -> Thrift.ThriftM p c s () +putMany __field__val + = do Thrift.ThriftEnv _proxy _channel _opts _counter <- Reader.ask + Trans.lift (putManyIO _proxy _channel _counter _opts __field__val) + +putManyIO :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.RpcOptions -> [Prelude.Int] -> Prelude.IO () +putManyIO _proxy _channel _counter _opts __field__val + = do _handle <- Concurrent.newEmptyMVar + send_putMany _proxy _channel _counter (Concurrent.putMVar _handle) + _opts + __field__val + Concurrent.takeMVar _handle >>= + Prelude.maybe (Prelude.return ()) Exception.throw + +send_putMany :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.SendCallback -> + Thrift.RpcOptions -> [Prelude.Int] -> Prelude.IO () +send_putMany _proxy _channel _counter _sendCob _rpcOpts + __field__val + = do _seqNum <- _counter + let + _callMsg + = LBS.toStrict + (ByteString.toLazyByteString + (_build_putMany _proxy _seqNum __field__val)) + Thrift.sendOnewayRequest _channel + (Thrift.Request _callMsg + (Thrift.setRpcPriority _rpcOpts Thrift.NormalPriority)) + _sendCob + +_build_putMany :: + Thrift.Protocol p => + Proxy.Proxy p -> Int.Int32 -> [Prelude.Int] -> ByteString.Builder +_build_putMany _proxy _seqNum __field__val + = Thrift.genMsgBegin _proxy "putMany" 1 _seqNum <> + Thrift.genStruct _proxy + (Thrift.genField _proxy "val" (Thrift.getListType _proxy) 1 0 + (Thrift.genList _proxy (Thrift.getI64Type _proxy) + (Thrift.genI64 _proxy . Prelude.fromIntegral) + __field__val) + : []) + <> Thrift.genMsgEnd _proxy + +get :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Thrift.ThriftM p c s Prelude.Int +get + = do Thrift.ThriftEnv _proxy _channel _opts _counter <- Reader.ask + Trans.lift (getIO _proxy _channel _counter _opts) + +getIO :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> Thrift.RpcOptions -> Prelude.IO Prelude.Int +getIO _proxy _channel _counter _opts + = do (_handle, _sendCob, _recvCob) <- Thrift.mkCallbacks + (recv_get _proxy) + send_get _proxy _channel _counter _sendCob _recvCob _opts + Thrift.wait _handle + +send_get :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.SendCallback -> + Thrift.RecvCallback -> Thrift.RpcOptions -> Prelude.IO () +send_get _proxy _channel _counter _sendCob _recvCob _rpcOpts + = do _seqNum <- _counter + let + _callMsg + = LBS.toStrict + (ByteString.toLazyByteString (_build_get _proxy _seqNum)) + Thrift.sendRequest _channel + (Thrift.Request _callMsg + (Thrift.setRpcPriority _rpcOpts Thrift.NormalPriority)) + _sendCob + _recvCob + +recv_get :: + (Thrift.Protocol p) => + Proxy.Proxy p -> + Thrift.Response -> + Prelude.Either Exception.SomeException Prelude.Int +recv_get _proxy (Thrift.Response _response _) + = Monad.join + (Arrow.left (Exception.SomeException . Thrift.ProtocolException) + (Parser.parse (_parse_get _proxy) _response)) + +_build_get :: + Thrift.Protocol p => + Proxy.Proxy p -> Int.Int32 -> ByteString.Builder +_build_get _proxy _seqNum + = Thrift.genMsgBegin _proxy "get" 1 _seqNum <> + Thrift.genStruct _proxy [] + <> Thrift.genMsgEnd _proxy + +_parse_get :: + Thrift.Protocol p => + Proxy.Proxy p -> + Parser.Parser (Prelude.Either Exception.SomeException Prelude.Int) +_parse_get _proxy + = do Thrift.MsgBegin _name _msgTy _ <- Thrift.parseMsgBegin _proxy + _result <- case _msgTy of + 1 -> Prelude.fail "get: expected reply but got function call" + 2 | _name == "get" -> + do let + _idMap = HashMap.fromList [("get_success", 0)] + _fieldBegin <- Thrift.parseFieldBegin _proxy 0 _idMap + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 0 | _type == + Thrift.getI64Type + _proxy + -> + Prelude.fmap + Prelude.Right + (Prelude.fromIntegral + <$> + Thrift.parseI64 + _proxy) + _ -> Prelude.fail + (Prelude.unwords + ["unrecognized exception, type:", + Prelude.show + _type, + "field id:", + Prelude.show _id]) + Thrift.FieldEnd -> Prelude.fail "no response" + | Prelude.otherwise -> Prelude.fail "reply function does not match" + 3 -> Prelude.fmap (Prelude.Left . Exception.SomeException) + (Thrift.parseStruct _proxy :: + Parser.Parser Thrift.ApplicationException) + 4 -> Prelude.fail + "get: expected reply but got oneway function call" + _ -> Prelude.fail "get: invalid message type" + Thrift.parseMsgEnd _proxy + Prelude.return _result + +unimplemented :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Thrift.ThriftM p c s () +unimplemented + = do Thrift.ThriftEnv _proxy _channel _opts _counter <- Reader.ask + Trans.lift (unimplementedIO _proxy _channel _counter _opts) + +unimplementedIO :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> Thrift.Counter -> Thrift.RpcOptions -> Prelude.IO () +unimplementedIO _proxy _channel _counter _opts + = do (_handle, _sendCob, _recvCob) <- Thrift.mkCallbacks + (recv_unimplemented _proxy) + send_unimplemented _proxy _channel _counter _sendCob _recvCob _opts + Thrift.wait _handle + +send_unimplemented :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.SendCallback -> + Thrift.RecvCallback -> Thrift.RpcOptions -> Prelude.IO () +send_unimplemented _proxy _channel _counter _sendCob _recvCob + _rpcOpts + = do _seqNum <- _counter + let + _callMsg + = LBS.toStrict + (ByteString.toLazyByteString (_build_unimplemented _proxy _seqNum)) + Thrift.sendRequest _channel + (Thrift.Request _callMsg + (Thrift.setRpcPriority _rpcOpts Thrift.NormalPriority)) + _sendCob + _recvCob + +recv_unimplemented :: + (Thrift.Protocol p) => + Proxy.Proxy p -> + Thrift.Response -> Prelude.Either Exception.SomeException () +recv_unimplemented _proxy (Thrift.Response _response _) + = Monad.join + (Arrow.left (Exception.SomeException . Thrift.ProtocolException) + (Parser.parse (_parse_unimplemented _proxy) _response)) + +_build_unimplemented :: + Thrift.Protocol p => + Proxy.Proxy p -> Int.Int32 -> ByteString.Builder +_build_unimplemented _proxy _seqNum + = Thrift.genMsgBegin _proxy "unimplemented" 1 _seqNum <> + Thrift.genStruct _proxy [] + <> Thrift.genMsgEnd _proxy + +_parse_unimplemented :: + Thrift.Protocol p => + Proxy.Proxy p -> + Parser.Parser (Prelude.Either Exception.SomeException ()) +_parse_unimplemented _proxy + = do Thrift.MsgBegin _name _msgTy _ <- Thrift.parseMsgBegin _proxy + _result <- case _msgTy of + 1 -> Prelude.fail + "unimplemented: expected reply but got function call" + 2 | _name == "unimplemented" -> + do let + _idMap = HashMap.fromList [] + _fieldBegin <- Thrift.parseFieldBegin _proxy 0 _idMap + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + _ -> Prelude.fail + (Prelude.unwords + ["unrecognized exception, type:", + Prelude.show + _type, + "field id:", + Prelude.show _id]) + Thrift.FieldEnd -> Prelude.return (Prelude.Right ()) + | Prelude.otherwise -> Prelude.fail "reply function does not match" + 3 -> Prelude.fmap (Prelude.Left . Exception.SomeException) + (Thrift.parseStruct _proxy :: + Parser.Parser Thrift.ApplicationException) + 4 -> Prelude.fail + "unimplemented: expected reply but got oneway function call" + _ -> Prelude.fail "unimplemented: invalid message type" + Thrift.parseMsgEnd _proxy + Prelude.return _result diff --git a/test/gen-hs2/Math/Calculator/Service.hs b/test/gen-hs2/Math/Calculator/Service.hs new file mode 100644 --- /dev/null +++ b/test/gen-hs2/Math/Calculator/Service.hs @@ -0,0 +1,416 @@ +----------------------------------------------------------------- +-- Autogenerated by Thrift +-- +-- DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING +-- @generated +----------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports#-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-record-updates#-} +{-# LANGUAGE GADTs #-} +module Math.Calculator.Service + (CalculatorCommand(..), reqName', reqParser', respWriter', + methodsInfo') + where +import qualified Control.Exception as Exception +import qualified Control.Monad.ST.Trans as ST +import qualified Control.Monad.Trans.Class as Trans +import qualified Data.ByteString.Builder as Builder +import qualified Data.Default as Default +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Int as Int +import qualified Data.Map.Strict as Map +import qualified Data.Proxy as Proxy +import qualified Data.Text as Text +import qualified Math.Adder.Service as Adder +import qualified Math.Types as Types +import qualified Prelude as Prelude +import qualified Thrift.Binary.Parser as Parser +import qualified Thrift.Codegen as Thrift +import qualified Thrift.Processor as Thrift +import qualified Thrift.Protocol.ApplicationException.Types + as Thrift +import Control.Applicative ((<*), (*>)) +import Data.Monoid ((<>)) +import Prelude ((<$>), (<*>), (++), (.), (==)) + +data CalculatorCommand a where + Divide :: + Prelude.Double -> + Prelude.Double -> CalculatorCommand Prelude.Double + QuotRem :: + Prelude.Int -> + Prelude.Int -> CalculatorCommand Types.QuotRemResponse + Put :: Prelude.Int -> CalculatorCommand () + PutMany :: [Prelude.Int] -> CalculatorCommand () + Get :: CalculatorCommand Prelude.Int + Unimplemented :: CalculatorCommand () + SuperAdder :: Adder.AdderCommand a -> CalculatorCommand a + +instance Thrift.Processor CalculatorCommand where + reqName = reqName' + reqParser = reqParser' + respWriter = respWriter' + methodsInfo _ = methodsInfo' + +reqName' :: CalculatorCommand a -> Text.Text +reqName' (Divide __field__dividend __field__divisor) = "divide" +reqName' (QuotRem __field__dividend __field__divisor) = "quotRem" +reqName' (Put __field__val) = "put" +reqName' (PutMany __field__val) = "putMany" +reqName' Get = "get" +reqName' Unimplemented = "unimplemented" +reqName' (SuperAdder x) = Adder.reqName' x + +reqParser' :: + Thrift.Protocol p => + Proxy.Proxy p -> + Text.Text -> Parser.Parser (Thrift.Some CalculatorCommand) +reqParser' _proxy "divide" + = ST.runSTT + (do Prelude.return () + __field__dividend <- ST.newSTRef Default.def + __field__divisor <- ST.newSTRef Default.def + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 1 | _type == + Thrift.getDoubleType _proxy + -> + do !_val <- Trans.lift + (Thrift.parseDouble + _proxy) + ST.writeSTRef + __field__dividend + _val + 2 | _type == + Thrift.getDoubleType _proxy + -> + do !_val <- Trans.lift + (Thrift.parseDouble + _proxy) + ST.writeSTRef __field__divisor + _val + _ -> Trans.lift + (Thrift.parseSkip _proxy _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do !__val__dividend <- ST.readSTRef + __field__dividend + !__val__divisor <- ST.readSTRef __field__divisor + Prelude.pure + (Thrift.Some (Divide __val__dividend __val__divisor)) + _idMap = HashMap.fromList [("dividend", 1), ("divisor", 2)] + _parse 0) +reqParser' _proxy "quotRem" + = ST.runSTT + (do Prelude.return () + __field__dividend <- ST.newSTRef Default.def + __field__divisor <- ST.newSTRef Default.def + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 1 | _type == Thrift.getI64Type _proxy + -> + do !_val <- Trans.lift + (Prelude.fromIntegral + <$> + Thrift.parseI64 + _proxy) + ST.writeSTRef + __field__dividend + _val + 2 | _type == Thrift.getI64Type _proxy + -> + do !_val <- Trans.lift + (Prelude.fromIntegral + <$> + Thrift.parseI64 + _proxy) + ST.writeSTRef __field__divisor + _val + _ -> Trans.lift + (Thrift.parseSkip _proxy _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do !__val__dividend <- ST.readSTRef + __field__dividend + !__val__divisor <- ST.readSTRef __field__divisor + Prelude.pure + (Thrift.Some (QuotRem __val__dividend __val__divisor)) + _idMap = HashMap.fromList [("dividend", 1), ("divisor", 2)] + _parse 0) +reqParser' _proxy "put" + = ST.runSTT + (do Prelude.return () + __field__val <- ST.newSTRef Default.def + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 1 | _type == Thrift.getI64Type _proxy + -> + do !_val <- Trans.lift + (Prelude.fromIntegral + <$> + Thrift.parseI64 + _proxy) + ST.writeSTRef __field__val + _val + _ -> Trans.lift + (Thrift.parseSkip _proxy _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do !__val__val <- ST.readSTRef __field__val + Prelude.pure (Thrift.Some (Put __val__val)) + _idMap = HashMap.fromList [("val", 1)] + _parse 0) +reqParser' _proxy "putMany" + = ST.runSTT + (do Prelude.return () + __field__val <- ST.newSTRef Default.def + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 1 | _type == + Thrift.getListType _proxy + -> + do !_val <- Trans.lift + (Prelude.snd <$> + Thrift.parseList + _proxy + (Prelude.fromIntegral + <$> + Thrift.parseI64 + _proxy)) + ST.writeSTRef __field__val + _val + _ -> Trans.lift + (Thrift.parseSkip _proxy _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do !__val__val <- ST.readSTRef __field__val + Prelude.pure (Thrift.Some (PutMany __val__val)) + _idMap = HashMap.fromList [("val", 1)] + _parse 0) +reqParser' _proxy "get" + = ST.runSTT + (do Prelude.return () + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + _ -> Trans.lift + (Thrift.parseSkip _proxy _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do Prelude.pure (Thrift.Some Get) + _idMap = HashMap.fromList [] + _parse 0) +reqParser' _proxy "unimplemented" + = ST.runSTT + (do Prelude.return () + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + _ -> Trans.lift + (Thrift.parseSkip _proxy _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do Prelude.pure (Thrift.Some Unimplemented) + _idMap = HashMap.fromList [] + _parse 0) +reqParser' _proxy funName + = do Thrift.Some x <- Adder.reqParser' _proxy funName + Prelude.return (Thrift.Some (SuperAdder x)) + +respWriter' :: + Thrift.Protocol p => + Proxy.Proxy p -> + Int.Int32 -> + CalculatorCommand a -> + Prelude.Either Exception.SomeException a -> + (Builder.Builder, + Prelude.Maybe (Exception.SomeException, Thrift.Blame)) +respWriter' _proxy _seqNum Divide{} _r + = (Thrift.genMsgBegin _proxy "divide" _msgType _seqNum <> _msgBody + <> Thrift.genMsgEnd _proxy, + _msgException) + where + (_msgType, _msgBody, _msgException) + = case _r of + Prelude.Left _ex | Prelude.Just + _e@Thrift.ApplicationException{} <- Exception.fromException _ex + -> + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (_ex, Thrift.ServerError)) + | Prelude.Just _e@Types.DivideByZero{} <- Exception.fromException + _ex + -> + (2, + Thrift.genStruct _proxy + [Thrift.genField _proxy "divisionError" + (Thrift.getStructType _proxy) + 1 + 0 + (Thrift.buildStruct _proxy _e)], + Prelude.Just (_ex, Thrift.ClientError)) + | Prelude.otherwise -> + let _e + = Thrift.ApplicationException (Text.pack (Prelude.show _ex)) + Thrift.ApplicationExceptionType_InternalError + in + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (Exception.toException _e, Thrift.ServerError)) + Prelude.Right _result -> (2, + Thrift.genStruct _proxy + [Thrift.genField _proxy "" (Thrift.getDoubleType _proxy) 0 0 + (Thrift.genDouble _proxy _result)], + Prelude.Nothing) +respWriter' _proxy _seqNum QuotRem{} _r + = (Thrift.genMsgBegin _proxy "quotRem" _msgType _seqNum <> _msgBody + <> Thrift.genMsgEnd _proxy, + _msgException) + where + (_msgType, _msgBody, _msgException) + = case _r of + Prelude.Left _ex | Prelude.Just + _e@Thrift.ApplicationException{} <- Exception.fromException _ex + -> + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (_ex, Thrift.ServerError)) + | Prelude.otherwise -> + let _e + = Thrift.ApplicationException (Text.pack (Prelude.show _ex)) + Thrift.ApplicationExceptionType_InternalError + in + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (Exception.toException _e, Thrift.ServerError)) + Prelude.Right _result -> (2, + Thrift.genStruct _proxy + [Thrift.genField _proxy "" (Thrift.getStructType _proxy) 0 0 + (Thrift.buildStruct _proxy _result)], + Prelude.Nothing) +respWriter' _proxy _seqNum Put{} _r + = (Thrift.genMsgBegin _proxy "put" _msgType _seqNum <> _msgBody <> + Thrift.genMsgEnd _proxy, + _msgException) + where + (_msgType, _msgBody, _msgException) + = case _r of + Prelude.Left _ex | Prelude.Just + _e@Thrift.ApplicationException{} <- Exception.fromException _ex + -> + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (_ex, Thrift.ServerError)) + | Prelude.otherwise -> + let _e + = Thrift.ApplicationException (Text.pack (Prelude.show _ex)) + Thrift.ApplicationExceptionType_InternalError + in + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (Exception.toException _e, Thrift.ServerError)) + Prelude.Right _result -> (2, Thrift.genStruct _proxy [], + Prelude.Nothing) +respWriter' _proxy _seqNum PutMany{} _r + = (Thrift.genMsgBegin _proxy "putMany" _msgType _seqNum <> _msgBody + <> Thrift.genMsgEnd _proxy, + _msgException) + where + (_msgType, _msgBody, _msgException) + = case _r of + Prelude.Left _ex | Prelude.Just + _e@Thrift.ApplicationException{} <- Exception.fromException _ex + -> + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (_ex, Thrift.ServerError)) + | Prelude.otherwise -> + let _e + = Thrift.ApplicationException (Text.pack (Prelude.show _ex)) + Thrift.ApplicationExceptionType_InternalError + in + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (Exception.toException _e, Thrift.ServerError)) + Prelude.Right _result -> (2, Thrift.genStruct _proxy [], + Prelude.Nothing) +respWriter' _proxy _seqNum Get{} _r + = (Thrift.genMsgBegin _proxy "get" _msgType _seqNum <> _msgBody <> + Thrift.genMsgEnd _proxy, + _msgException) + where + (_msgType, _msgBody, _msgException) + = case _r of + Prelude.Left _ex | Prelude.Just + _e@Thrift.ApplicationException{} <- Exception.fromException _ex + -> + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (_ex, Thrift.ServerError)) + | Prelude.otherwise -> + let _e + = Thrift.ApplicationException (Text.pack (Prelude.show _ex)) + Thrift.ApplicationExceptionType_InternalError + in + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (Exception.toException _e, Thrift.ServerError)) + Prelude.Right _result -> (2, + Thrift.genStruct _proxy + [Thrift.genField _proxy "" (Thrift.getI64Type _proxy) 0 0 + ((Thrift.genI64 _proxy . Prelude.fromIntegral) _result)], + Prelude.Nothing) +respWriter' _proxy _seqNum Unimplemented{} _r + = (Thrift.genMsgBegin _proxy "unimplemented" _msgType _seqNum <> + _msgBody + <> Thrift.genMsgEnd _proxy, + _msgException) + where + (_msgType, _msgBody, _msgException) + = case _r of + Prelude.Left _ex | Prelude.Just + _e@Thrift.ApplicationException{} <- Exception.fromException _ex + -> + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (_ex, Thrift.ServerError)) + | Prelude.otherwise -> + let _e + = Thrift.ApplicationException (Text.pack (Prelude.show _ex)) + Thrift.ApplicationExceptionType_InternalError + in + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (Exception.toException _e, Thrift.ServerError)) + Prelude.Right _result -> (2, Thrift.genStruct _proxy [], + Prelude.Nothing) +respWriter' _proxy _seqNum (SuperAdder _x) _r + = Adder.respWriter' _proxy _seqNum _x _r + +methodsInfo' :: Map.Map Text.Text Thrift.MethodInfo +methodsInfo' + = Map.union + (Map.fromList + [("divide", Thrift.MethodInfo Thrift.NormalPriority Prelude.False), + ("quotRem", Thrift.MethodInfo Thrift.NormalPriority Prelude.False), + ("put", Thrift.MethodInfo Thrift.NormalPriority Prelude.True), + ("putMany", Thrift.MethodInfo Thrift.NormalPriority Prelude.True), + ("get", Thrift.MethodInfo Thrift.NormalPriority Prelude.False), + ("unimplemented", + Thrift.MethodInfo Thrift.NormalPriority Prelude.False)]) + Adder.methodsInfo' diff --git a/test/gen-hs2/Math/Types.hs b/test/gen-hs2/Math/Types.hs new file mode 100644 --- /dev/null +++ b/test/gen-hs2/Math/Types.hs @@ -0,0 +1,148 @@ +----------------------------------------------------------------- +-- Autogenerated by Thrift +-- +-- DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING +-- @generated +----------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports#-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-record-updates#-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Math.Types + (DivideByZero(DivideByZero), + QuotRemResponse(QuotRemResponse, quotRemResponse_quot, + quotRemResponse_rem)) + where +import qualified Control.DeepSeq as DeepSeq +import qualified Control.Exception as Exception +import qualified Control.Monad as Monad +import qualified Control.Monad.ST.Trans as ST +import qualified Control.Monad.Trans.Class as Trans +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import qualified Data.Default as Default +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Hashable as Hashable +import qualified Data.List as List +import qualified Data.Ord as Ord +import qualified Prelude as Prelude +import qualified Thrift.Binary.Parser as Parser +import qualified Thrift.CodegenTypesOnly as Thrift +import Control.Applicative ((<|>), (*>), (<*)) +import Data.Aeson ((.:), (.:?), (.=), (.!=)) +import Data.Monoid ((<>)) +import Prelude ((.), (<$>), (<*>), (>>=), (==), (/=), (<), (++)) + +data DivideByZero = DivideByZero{} + deriving (Prelude.Eq, Prelude.Show, Prelude.Ord) + +instance Aeson.ToJSON DivideByZero where + toJSON DivideByZero = Aeson.object Prelude.mempty + +instance Thrift.ThriftStruct DivideByZero where + buildStruct _proxy DivideByZero = Thrift.genStruct _proxy [] + parseStruct _proxy + = ST.runSTT + (do Prelude.return () + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + _ -> Trans.lift + (Thrift.parseSkip _proxy + _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do Prelude.pure (DivideByZero) + _idMap = HashMap.fromList [] + _parse 0) + +instance DeepSeq.NFData DivideByZero where + rnf DivideByZero = () + +instance Default.Default DivideByZero where + def = DivideByZero + +instance Hashable.Hashable DivideByZero where + hashWithSalt __salt DivideByZero = __salt + +instance Exception.Exception DivideByZero + +data QuotRemResponse = QuotRemResponse{quotRemResponse_quot :: + Prelude.Int, + quotRemResponse_rem :: Prelude.Int} + deriving (Prelude.Eq, Prelude.Show, Prelude.Ord) + +instance Aeson.ToJSON QuotRemResponse where + toJSON (QuotRemResponse __field__quot __field__rem) + = Aeson.object + ("quot" .= __field__quot : "rem" .= __field__rem : Prelude.mempty) + +instance Thrift.ThriftStruct QuotRemResponse where + buildStruct _proxy (QuotRemResponse __field__quot __field__rem) + = Thrift.genStruct _proxy + (Thrift.genField _proxy "quot" (Thrift.getI64Type _proxy) 1 0 + ((Thrift.genI64 _proxy . Prelude.fromIntegral) __field__quot) + : + Thrift.genField _proxy "rem" (Thrift.getI64Type _proxy) 2 1 + ((Thrift.genI64 _proxy . Prelude.fromIntegral) __field__rem) + : []) + parseStruct _proxy + = ST.runSTT + (do Prelude.return () + __field__quot <- ST.newSTRef Default.def + __field__rem <- ST.newSTRef Default.def + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 1 | _type == + Thrift.getI64Type _proxy + -> + do !_val <- Trans.lift + (Prelude.fromIntegral + <$> + Thrift.parseI64 + _proxy) + ST.writeSTRef __field__quot + _val + 2 | _type == + Thrift.getI64Type _proxy + -> + do !_val <- Trans.lift + (Prelude.fromIntegral + <$> + Thrift.parseI64 + _proxy) + ST.writeSTRef __field__rem + _val + _ -> Trans.lift + (Thrift.parseSkip _proxy + _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do !__val__quot <- ST.readSTRef __field__quot + !__val__rem <- ST.readSTRef __field__rem + Prelude.pure (QuotRemResponse __val__quot __val__rem) + _idMap = HashMap.fromList [("quot", 1), ("rem", 2)] + _parse 0) + +instance DeepSeq.NFData QuotRemResponse where + rnf (QuotRemResponse __field__quot __field__rem) + = DeepSeq.rnf __field__quot `Prelude.seq` + DeepSeq.rnf __field__rem `Prelude.seq` () + +instance Default.Default QuotRemResponse where + def = QuotRemResponse Default.def Default.def + +instance Hashable.Hashable QuotRemResponse where + hashWithSalt __salt (QuotRemResponse _quot _rem) + = Hashable.hashWithSalt (Hashable.hashWithSalt __salt _quot) _rem diff --git a/test/helpers/Network.hs b/test/helpers/Network.hs new file mode 100644 --- /dev/null +++ b/test/helpers/Network.hs @@ -0,0 +1,20 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE CPP #-} +module Network where + +import Data.ByteString.Char8 (ByteString, pack) + +testServerHost :: ByteString +testServerHost = pack +#ifdef IPV4 + "127.0.0.1" +#else + "::1" +#endif diff --git a/test/helpers/TestChannel.hs b/test/helpers/TestChannel.hs new file mode 100644 --- /dev/null +++ b/test/helpers/TestChannel.hs @@ -0,0 +1,63 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module TestChannel + ( TestChannel(..), Req(..) + , runServer + , runTestServer + ) where + +import Control.Concurrent +import Control.Exception (SomeException) +import Control.Monad +import Data.ByteString (ByteString) +import Data.Proxy + +import Thrift.Channel +import Thrift.Monad (getRpcPriority, newCounter) +import Thrift.Processor +import Thrift.Protocol + +newtype TestChannel s = TestChannel (MVar Req) + +data Req = Req ByteString RecvCallback + +instance ClientChannel TestChannel where + sendRequest (TestChannel reqBuf) Request{..} sendCob recvCob = + case getRpcPriority reqOptions of + Nothing -> send () + Just NormalPriority -> send () + _ -> sendCob $ Just $ ChannelException "non-Normal priority" + where + send () = sendCob Nothing >> putMVar reqBuf (Req reqMsg recvCob) + + sendOnewayRequest (TestChannel reqBuf) Request{..} sendCob = do + putMVar reqBuf $ Req reqMsg (\_ -> return ()) + sendCob Nothing + +runServer + :: (Processor c, Protocol p) + => Proxy p + -> TestChannel s + -> (forall r . c r -> IO r) + -> (forall r . c r -> Either SomeException r -> Header) + -> IO () +runServer p ch handler postProcess = do + counter <- newCounter + runTestServer ch $ \bytes -> do + seqNum <- counter + process p seqNum handler postProcess bytes + +runTestServer + :: TestChannel s + -> (ByteString -> IO (ByteString, a, Header)) + -> IO () +runTestServer (TestChannel req) handler = forever $ do + Req bytes callback <- takeMVar req + (handled, _, headers) <- handler bytes + callback $ Right $ Response handled headers diff --git a/test/if/echoer.thrift b/test/if/echoer.thrift new file mode 100644 --- /dev/null +++ b/test/if/echoer.thrift @@ -0,0 +1,13 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +include "test/if/math.thrift" + +service Echoer extends math.Calculator { + string echo(1: string input); +} diff --git a/test/if/math.thrift b/test/if/math.thrift new file mode 100644 --- /dev/null +++ b/test/if/math.thrift @@ -0,0 +1,34 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +exception DivideByZero {} + +service Adder { + i64 add(1: i64 x, 2: i64 y); +} + +struct QuotRemResponse { + 1: i64 quot; + 2: i64 rem; +} + +service Calculator extends Adder { + double divide(1: double dividend, 2: double divisor) throws ( + 1: DivideByZero divisionError, + ); + + QuotRemResponse quotRem(1: i64 dividend, 2: i64 divisor); + + oneway void put(1: i64 val); + + oneway void putMany(1: list val) (haxl.batched); + + i64 get(); + + void unimplemented(); +} diff --git a/test/lib/TestCommon.hs b/test/lib/TestCommon.hs new file mode 100644 --- /dev/null +++ b/test/lib/TestCommon.hs @@ -0,0 +1,131 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module TestCommon where + +import Control.Exception (throw, throwIO, evaluate) +import Control.Monad +import Control.Monad.Trans.Class +import Data.IORef +import Test.HUnit hiding (State) + +import Thrift.Api +import Thrift.Channel +import Thrift.Monad +import Thrift.Protocol.ApplicationException.Types + +import Math.Types +import Math.Adder.Client +import Math.Adder.Service +import Math.Calculator.Client +import Math.Calculator.Service + +-- Server Implementation for the 'Calculator' service + +type State = IORef Int + +initServerState :: IO State +initServerState = newIORef 0 + +processCommand :: State -> CalculatorCommand a -> IO a +processCommand _ (SuperAdder (Add x y)) = pure $ x + y +processCommand _ (Divide x y) + | y == 0 = throwIO DivideByZero + | otherwise = pure $ x / y +processCommand _ (QuotRem x y) = pure $ QuotRemResponse (x `quot` y) (x `rem` y) +processCommand state (Put x) = writeIORef state x +processCommand state (PutMany xs) = mapM_ (writeIORef state) xs +processCommand state Get = readIORef state +processCommand _ Unimplemented = + throw $ ApplicationException "" ApplicationExceptionType_UnknownMethod + + +-- common client computations/tests used with diffeerent channel implementations + +-- if needed, this 'Calculator' could just become a type +-- parameter, in case such utilities are needed for other +-- test suites. +data ChannelTest = ChannelTest + { ctestName :: String + , ctestOpts :: RpcOptions + , ctestAct :: Thrift Calculator () + } + +-- | Package up a test label and the corresponding client +-- computation, to later be executed against a specific +-- channel implementation and server. +channelTest + :: String -> Thrift Calculator () -> ChannelTest +channelTest lbl comp = channelTestWithOpts lbl defaultRpcOptions comp + +-- | Like 'channelTest', but with the ability to pass 'RpcOptions' to the +-- test. +channelTestWithOpts + :: String -> RpcOptions -> Thrift Calculator () -> ChannelTest +channelTestWithOpts = ChannelTest + +runChannelTests + :: (String -> RpcOptions -> Thrift Calculator () -> Test) + -> [ChannelTest] + -> [Test] +runChannelTests testFun tests = + map (\ChannelTest{..} -> testFun ctestName ctestOpts ctestAct) tests + +addTest :: ChannelTest +addTest = channelTest "add test" $ do + result <- add 5 2 + lift $ assertEqual "5 + 2 = 7" 7 result + +divTest :: ChannelTest +divTest = channelTest "divide test" $ do + result <- divide 10 2 + lift $ assertEqual "10 / 2 = 5" 5 result + +putGetTest :: ChannelTest +putGetTest = channelTest "put get" $ do + let value = 99 + put value + result <- get + lift $ assertEqual "put 99 = get" value result + +putPutGetTest :: ChannelTest +putPutGetTest = channelTest "put put get" $ do + let value1 = 99 + value2 = 100 + put value1 + put value2 + result <- get + lift $ assertEqual "put 99 then put 100 = get (= put 100)" value2 result + +exceptionTest :: ChannelTest +exceptionTest = channelTest "exception test" $ + (void . lift . evaluate =<< divide 0 0) + `catchThrift` \DivideByZero -> return () + +optionsTest :: ChannelTest +optionsTest = channelTestWithOpts "options test" opts $ + (void . lift . evaluate =<< (add 0 0 *> error "fail")) + `catchThrift` \ChannelException{} -> return () + where + opts = setRpcPriority defaultRpcOptions High + +unimplementedTest :: ChannelTest +unimplementedTest = channelTest "unimplemented test" $ + unimplemented `catchThrift` \ApplicationException{} -> return () + +multiTest :: ChannelTest +multiTest = channelTest "multiple requests" $ do + r1 <- add 2 2 + lift $ assertEqual "2 + 2 = 4" 4 r1 + + r2 <- divide 64 16 + lift $ assertEqual "64 / 16 = 4" 4 r2 + + put 100 + r3 <- get + lift $ assertEqual "put = get" 100 r3 diff --git a/thrift-lib.cabal b/thrift-lib.cabal new file mode 100644 --- /dev/null +++ b/thrift-lib.cabal @@ -0,0 +1,243 @@ +cabal-version: 3.6 + +-- Copyright (c) Facebook, Inc. and its affiliates. + +name: thrift-lib +version: 0.1.0.1 +synopsis: Libraries for Haskell Thrift +homepage: https://github.com/facebookincubator/hsthrift +bug-reports: https://github.com/facebookincubator/hsthrift/issues +license: BSD-3-Clause +license-file: LICENSE +author: Facebook, Inc. +maintainer: hsthrift-team@fb.com +copyright: (c) Facebook, All Rights Reserved +category: Thrift +build-type: Simple +extra-source-files: if/*.thrift, + test/if/*.thrift +extra-doc-files: CHANGELOG.md + +description: + Support for building client and server applications that + communicate using the Thrift protocols. + + NOTE: for build instructions and documentation, see + + +source-repository head + type: git + location: https://github.com/facebookincubator/hsthrift.git + +common fb-haskell + default-language: Haskell2010 + default-extensions: + BangPatterns + BinaryLiterals + DataKinds + DeriveDataTypeable + DeriveGeneric + EmptyCase + ExistentialQuantification + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + MultiWayIf + NoMonomorphismRestriction + OverloadedStrings + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeSynonymInstances + NondecreasingIndentation + build-tool-depends: thrift-compiler:thrift-compiler + + +library + import: fb-haskell + exposed-modules: + Thrift.HasFields + Thrift.Monad + Thrift.CodegenTypesOnly + Thrift.Processor + Thrift.Api + Thrift.Codegen + Thrift.Channel + Thrift.Channel.SocketChannel + Thrift.Channel.SocketChannel.Server + Thrift.Protocol + Thrift.Protocol.Compact + Thrift.Protocol.Id + Thrift.Protocol.JSON + Thrift.Protocol.Binary + Thrift.Protocol.Binary.Internal + Thrift.Protocol.JSON.Base64 + Thrift.Protocol.JSON.String + Thrift.Binary.Parser + Thrift.Protocol.ApplicationException.Types + Thrift.Protocol.RpcOptions.Types + Thrift.Util + + hs-source-dirs: . gen-hs2 + + -- needed for fb-utils + extra-libraries: stdc++ + + build-depends: + QuickCheck >= 2.14.3 && < 2.15, + STMonadTrans >= 0.4.8 && < 0.5, + aeson >= 1 && < 2.3, + aeson-pretty >= 0.8.10 && < 0.9, + async ^>= 2.2, + base >=4.11.1 && <4.20, + bytestring >=0.10.8.2 && <0.13, + bytestring-lexing >= 0.5.0 && < 0.6, + containers >= 0.6 && < 0.7, + data-default >= 0.8.0 && < 0.9, + deepseq >= 1.4.4 && < 1.6, + fb-stubs >= 0.1.0 && < 0.2, + fb-util >= 0.1.0 && < 0.2, + filepath >= 1.4.2 && < 1.5, + ghc >= 8.6.5 && < 9.9, + ghc-prim >= 0.5 && < 0.12, + hashable >=1.2.7.0 && <1.5, + hspec >= 2.11.10 && < 2.12, + hspec-contrib >= 0.5.2 && < 0.6, + network >= 3.2.7 && < 3.3, + scientific >= 0.3.7 && < 0.4, + some >= 1.0.6 && < 1.1, + text >= 1.2.3 && < 1.3, + text-show >= 3.10.5 && < 3.11, + transformers >= 0.5.6 && < 0.7, + unordered-containers >= 0.2.9.0 && < 0.3, + vector >= 0.12.0.1 && < 0.14, + word8 >= 0.1.3 && < 0.2 + + if flag(tests_use_ipv4) + -- for SocketChannel.hs + cpp-options: -DIPV4 + +flag tests_use_ipv4 + description: Force tests to use IPV4 whenever bringing thrift clients/servers up + default: False + manual: True + +-- This will be used by other packages +library test-helpers + import: fb-haskell + visibility: public + hs-source-dirs: test/helpers + exposed-modules: + Network + TestChannel + if flag(tests_use_ipv4) + -- for test/Network.hs + cpp-options: -DIPV4 + build-depends: base, + bytestring, + network, + thrift-lib, + +common test-deps + if flag(tests_use_ipv4) + -- for test/Network.hs + cpp-options: -DIPV4 + -- for test/cpp/MathServer.cpp + cxx-options: -DIPV4 + build-depends: async ^>= 2.2, + base, + bytestring, + fb-stubs, + fb-util, + filepath, + ghc-prim, + hspec, + hspec-contrib, + HUnit ^>= 1.6.1, + network, + text, + thrift-lib, + -- vvv for HsTest.Types + deepseq, + transformers, + aeson, + data-default, + unordered-containers, + hashable, + containers, + vector, + QuickCheck, + STMonadTrans, + thrift-lib:test-helpers, + +-- This is used by local tests only +library test-lib + import: fb-haskell, test-deps + visibility: private + hs-source-dirs: + test/lib, + test/gen-hs2, + exposed-modules: + TestCommon + Math.Types + Math.Adder.Client + Math.Calculator.Client + Math.Adder.Service + Math.Calculator.Service + HsTest.Types + +common test-common + import: test-deps + hs-source-dirs: test + build-depends: + thrift-lib:test-helpers, + thrift-lib:test-lib + +test-suite channel + import: fb-haskell, test-common + type: exitcode-stdio-1.0 + main-is: ChannelTest.hs + ghc-options: -main-is ChannelTest + +test-suite socket-channel + import: fb-haskell, test-common + type: exitcode-stdio-1.0 + main-is: SocketChannelTest.hs + ghc-options: -main-is SocketChannelTest + +test-suite client + import: fb-haskell, test-common + type: exitcode-stdio-1.0 + main-is: ClientTest.hs + ghc-options: -main-is ClientTest + +test-suite binary-parser + import: fb-haskell, test-common + type: exitcode-stdio-1.0 + main-is: BinaryParserTest.hs + ghc-options: -main-is BinaryParserTest + +test-suite json-parsing + import: fb-haskell, test-common + type: exitcode-stdio-1.0 + main-is: JSONStringTest.hs + ghc-options: -main-is JSONStringTest + +test-suite json-num + import: fb-haskell, test-common + type: exitcode-stdio-1.0 + main-is: JSONNumTest.hs + ghc-options: -main-is JSONNumTest + +test-suite json-null + import: fb-haskell, test-common + type: exitcode-stdio-1.0 + main-is: JSONNullTest.hs + ghc-options: -main-is JSONNullTest