packages feed

thrift-lib (empty) → 0.1.0.1

raw patch · 45 files changed

+6785/−0 lines, 45 filesdep +HUnitdep +QuickCheckdep +STMonadTranssetup-changed

Dependencies added: HUnit, QuickCheck, STMonadTrans, aeson, aeson-pretty, async, base, bytestring, bytestring-lexing, containers, data-default, deepseq, fb-stubs, fb-util, filepath, ghc, ghc-prim, hashable, hspec, hspec-contrib, network, scientific, some, text, text-show, thrift-lib, transformers, unordered-containers, vector, word8

Files

+ CHANGELOG.md view
@@ -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.
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,5 @@+-- Copyright (c) Facebook, Inc. and its affiliates.++-- @nolint+import Distribution.Simple+main = defaultMain
+ Thrift/Api.hs view
@@ -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
+ Thrift/Binary/Parser.hs view
@@ -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
+ Thrift/Channel.hs view
@@ -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
+ Thrift/Channel/SocketChannel.hs view
@@ -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
+ Thrift/Channel/SocketChannel/Server.hs view
@@ -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
+ Thrift/Codegen.hs view
@@ -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
+ Thrift/CodegenTypesOnly.hs view
@@ -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
+ Thrift/HasFields.hs view
@@ -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
+ Thrift/Monad.hsc view
@@ -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
+ Thrift/Processor.hs view
@@ -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)
+ Thrift/Protocol.hs view
@@ -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)
+ Thrift/Protocol/Binary.hs view
@@ -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
+ Thrift/Protocol/Binary/Internal.hs view
@@ -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
+ Thrift/Protocol/Compact.hs view
@@ -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)
+ Thrift/Protocol/Id.hs view
@@ -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
+ Thrift/Protocol/JSON.hs view
@@ -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 *>)
+ Thrift/Protocol/JSON/Base64.hs view
@@ -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
+ Thrift/Protocol/JSON/String.hs view
@@ -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
+ Thrift/Util.hs view
@@ -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
+ gen-hs2/Thrift/Protocol/ApplicationException/Types.hs view
@@ -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
+ gen-hs2/Thrift/Protocol/RpcOptions/Types.hs view
@@ -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)
+ if/ApplicationException.thrift view
@@ -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;+}
+ if/RpcOptions.thrift view
@@ -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<string, string> headers;+} (hs.prefix = "rpc_")
+ test/BinaryParserTest.hs view
@@ -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+  ]
+ test/ChannelTest.hs view
@@ -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
+ test/ClientTest.hs view
@@ -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) (\_ _ -> [])
+ test/JSONNullTest.hs view
@@ -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+  ]
+ test/JSONNumTest.hs view
@@ -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
+ test/JSONStringTest.hs view
@@ -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\""+  ]
+ test/SocketChannelTest.hs view
@@ -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
+ test/gen-hs2/HsTest/Types.hs view
@@ -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
+ test/gen-hs2/Math/Adder/Client.hs view
@@ -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
+ test/gen-hs2/Math/Adder/Service.hs view
@@ -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)]
+ test/gen-hs2/Math/Calculator/Client.hs view
@@ -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
+ test/gen-hs2/Math/Calculator/Service.hs view
@@ -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'
+ test/gen-hs2/Math/Types.hs view
@@ -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
+ test/helpers/Network.hs view
@@ -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
+ test/helpers/TestChannel.hs view
@@ -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
+ test/if/echoer.thrift view
@@ -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);+}
+ test/if/math.thrift view
@@ -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<i64> val) (haxl.batched);++  i64 get();++  void unimplemented();+}
+ test/lib/TestCommon.hs view
@@ -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
+ thrift-lib.cabal view
@@ -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+    <https://github.com/facebookincubator/hsthrift>++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