thrift-http (empty) → 0.1.0.1
raw patch · 15 files changed
+2393/−0 lines, 15 filesdep +HUnitdep +STMonadTransdep +aeson
Dependencies added: HUnit, STMonadTrans, aeson, async, base, bytestring, containers, data-default, deepseq, fb-stubs, fb-util, ghc-prim, hashable, hspec, hspec-contrib, http-client, http-types, network, streaming-commons, text, thrift-http, thrift-lib, transformers, unordered-containers, utf8-string, wai, warp
Files
- LICENSE +30/−0
- Thrift/Channel/HTTP.hs +103/−0
- Thrift/Server/HTTP.hs +146/−0
- test/ServerTest.hs +144/−0
- test/common/CalculatorHandler.hs +43/−0
- test/common/EchoHandler.hs +27/−0
- test/gen-hs2/Echoer/Echoer/Client.hs +153/−0
- test/gen-hs2/Echoer/Echoer/Service.hs +132/−0
- test/gen-hs2/Echoer/Types.hs +18/−0
- test/gen-hs2/Math/Adder/Client.hs +153/−0
- test/gen-hs2/Math/Adder/Service.hs +131/−0
- test/gen-hs2/Math/Calculator/Client.hs +598/−0
- test/gen-hs2/Math/Calculator/Service.hs +416/−0
- test/gen-hs2/Math/Types.hs +148/−0
- thrift-http.cabal +151/−0
+ 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.
+ Thrift/Channel/HTTP.hs view
@@ -0,0 +1,103 @@+{-+ 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.Channel.HTTP (+ HTTPConfig(..),+ withHTTPChannel,+ withHTTPChannelIO,+ ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LBS+import Data.Proxy+import qualified Data.Text.Encoding as Text+import Network.HTTP.Client hiding (Proxy)+import Network.HTTP.Types++import Thrift.Channel+import Thrift.Monad+import Thrift.Protocol+import Thrift.Protocol.Id++data HTTPChannel s = HTTPChannel+ { httpConfig :: HTTPConfig s+ , httpManager :: Manager+ }++data HTTPConfig s = HTTPConfig+ { httpHost :: ByteString+ , httpPort :: Int+ , httpProtocolId :: ProtocolId+ , httpResponseTimeout :: Maybe Int -- ^ microseconds+ }+ deriving Show++withHTTPChannel+ :: HTTPConfig t+ -> (forall p . Protocol p => ThriftM p HTTPChannel t a)+ -> IO a+withHTTPChannel config@HTTPConfig{..} action = do+ manager <- newManager defaultManagerSettings {+ managerResponseTimeout =+ maybe responseTimeoutNone responseTimeoutMicro httpResponseTimeout }+ withProxy httpProtocolId $ \proxy ->+ runAction (HTTPChannel config manager) action proxy+ where+ runAction+ :: Protocol p+ => HTTPChannel t+ -> ThriftM p HTTPChannel t a+ -> Proxy p+ -> IO a+ runAction c a _ = runThrift a c++withHTTPChannelIO+ :: HTTPConfig t+ -> (forall p . Protocol p => HTTPChannel t -> Proxy p -> IO a)+ -> IO a+withHTTPChannelIO config@HTTPConfig{..} action = do+ manager <- newManager defaultManagerSettings+ withProxy httpProtocolId $ \proxy ->+ action (HTTPChannel config manager) proxy++instance ClientChannel HTTPChannel where+ sendRequest = httpRequest+ sendOnewayRequest chan req sendCb = httpRequest chan req sendCb (\_ -> return ())++httpRequest+ :: HTTPChannel t+ -> Thrift.Channel.Request+ -> SendCallback+ -> RecvCallback+ -> IO ()+httpRequest HTTPChannel{..} Request{..} sendCb recvCb = do+ let !prot = httpProtocolId httpConfig+ let request = defaultRequest+ { host = httpHost httpConfig+ , port = httpPort httpConfig+ , method = "POST"+ , requestHeaders =+ [ (hContentType, if+ | prot == binaryProtocolId ->+ "application/x-thrift-binary"+ | prot == compactProtocolId ->+ "application/x-thrift-compact"+ | otherwise -> -- later: JSON+ "application/x-thrift-binary") ]+ , requestBody = RequestBodyBS reqMsg+ }+ -- TODO: rpcOpts+ response <- httpLbs request httpManager+ sendCb Nothing -- TODO?+ let s = responseStatus response+ if s == status200 then+ recvCb $ Right Response+ { respMsg = LBS.toStrict (responseBody response)+ , respHeader = [] }+ else+ recvCb (Left (ChannelException (Text.decodeUtf8 (statusMessage s))))
+ Thrift/Server/HTTP.hs view
@@ -0,0 +1,146 @@+{-+ 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.+-}++-- | Support for creating a Thrift-over-HTTP server++{-# LANGUAGE TypeApplications #-}+module Thrift.Server.HTTP (+ ServerOptions(..),+ Server(..),+ defaultOptions,+ withBackgroundServer,+ withBackgroundServer',+ thriftApplication,+ ) where++import Data.ByteString (ByteString)+import Control.Concurrent+import Control.Concurrent.Async+import Control.Exception+import qualified Data.ByteString.Lazy as LBS+import Data.Proxy+import Data.String+import Data.Streaming.Network (bindPortTCP, bindRandomPortTCP)+import Network.HTTP.Types+import Network.Socket (close)+import Network.Wai.Handler.Warp+import Network.Wai++import Thrift.Processor hiding (Header)+import qualified Thrift.Processor as Thrift+import Thrift.Protocol+import Thrift.Protocol.Binary+import Thrift.Protocol.Compact+import Thrift.Protocol.JSON++-- TODO:+-- - one-way requests are currently treated as 2-way. Can we do any+-- better?++-- | Options for creating a Thrift-over-HTTP service.+data ServerOptions = ServerOptions+ { desiredPort :: Maybe Int+ -- ^ If 'Nothing', creates the server on a random free port,+ -- passing the actual port number as 'serverPort'.+ , numWorkerThreads :: Maybe Int+ -- ^ Currently ignored, provided for compatibility with CppServer+ , warpSettings :: Settings+ }++-- | Default options for creating a Thrift-over-HTTP service.+defaultOptions :: ServerOptions+defaultOptions = ServerOptions+ { desiredPort = Nothing+ , numWorkerThreads = Nothing+ , warpSettings = setHost (fromString "!6") defaultSettings+ -- IPv6 only by default+ }++-- | A running HTTP server.+data Server = Server+ { serverPort :: Int+ -- The actual port number, which might be useful if+ -- 'desiredPort' was 'Nothing'.+ , serverAsync :: Async ()+ -- The 'Async' running the HTTP server+ }++-- | Create an HTTP server for a Thrift service from the given 'ServerOptions'.+-- This is a simple wrapper around Warp's 'runSettings' that optionally creates+-- the server on a random port, and also wait for the server to start before+-- invoking the given action. Shuts down the server when the action returns.+withBackgroundServer+ :: forall s a . (Processor s)+ => (forall r . s r -> IO r) -- ^ handler to use+ -> ServerOptions+ -> (Server -> IO a) -- ^ action to run while the server is up+ -> IO a+withBackgroundServer handler = withBackgroundServer' handler (\_ _ -> [])++-- | Create an HTTP server for a Thrift service from the given 'ServerOptions'.+-- This is a simple wrapper around Warp's 'runSettings' that optionally creates+-- the server on a random port, and also wait for the server to start before+-- invoking the given action. Shuts down the server when the action returns.+withBackgroundServer'+ :: forall s a . (Processor s)+ => (forall r . s r -> IO r) -- ^ handler to use+ -> (forall r . s r -> Either SomeException r -> Thrift.Header)+ -> ServerOptions+ -> (Server -> IO a) -- ^ action to run while the server is up+ -> IO a+withBackgroundServer' handler postProcess ServerOptions{..} action = do+ ready <- newEmptyMVar+ let+ host = getHost warpSettings+ application = thriftApplication handler postProcess++ settings =+ maybe id setPort desiredPort $+ setBeforeMainLoop (putMVar ready ())+ warpSettings++ go port sock =+ withAsync (runSettingsSocket settings sock application) $ \a -> do+ takeMVar ready+ action (Server port a)++ case desiredPort of+ Nothing ->+ bracket (bindRandomPortTCP host) (close . snd) $ \(port,sock) ->+ go port sock+ Just port ->+ bracket (bindPortTCP port host) close (go port)++-- | Make a WAI 'Application' for a Thrift service. Use this with a+-- transport layer such as Warp to make a complete server, or call+-- 'withBackgroundServer' to do it all.+thriftApplication+ :: forall s . (Processor s)+ => (forall r . s r -> IO r) -- ^ handler to use+ -> (forall r . s r -> Either SomeException r -> Thrift.Header)+ -> Application+thriftApplication handler postProcess req respond = do+ body <- strictRequestBody req+ withProto (requestHeaders req) $ \proto contentType -> do+ (res, _maybeEx, _headers) <-+ process proto 0 handler postProcess (LBS.toStrict body)+ respond $ responseLBS+ status200+ [(hContentType, contentType)]+ (LBS.fromStrict res)+ where+ withProto+ :: [Header]+ -> (forall p . Protocol p => Proxy p -> ByteString -> IO b)+ -> IO b+ withProto hdrs f =+ case [ t | (header,t) <- hdrs, header == hContentType ] of+ t@"application/x-thrift-binary" : _ -> f (Proxy @Binary) t+ t@"application/x-thrift-compact" : _ -> f (Proxy @Compact) t+ t@"application/x-thrift-json" : _ -> f (Proxy @JSON) t+ _ -> f (Proxy @Binary) "application/x-thrift-binary"
+ test/ServerTest.hs view
@@ -0,0 +1,144 @@+{-+ 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 ServerTest (main) where++import Control.Exception hiding (DivideByZero)+import Control.Monad+import Control.Monad.Trans.Class+import Data.Either++import Facebook.Init+-- import Network (testServerHost)+import Test.HUnit+import TestRunner++import Thrift.Api+import Thrift.Monad+import Thrift.Protocol.ApplicationException.Types+import Thrift.Protocol.Id+import Thrift.Channel.HTTP+import Thrift.Server.HTTP++import Math.Adder.Client+import Math.Calculator.Client+import Math.Types+import Echoer.Echoer.Client+import EchoHandler++withTestServer :: ServerOptions -> (Int -> IO a) -> IO a+withTestServer serverOptions action = do+ st <- initEchoerState+ withBackgroundServer (echoHandler st) serverOptions $+ \Server{..} -> action serverPort++mkHTTPConfig :: Int -> ProtocolId -> HTTPConfig t+mkHTTPConfig port protId =+ HTTPConfig+ { httpHost = "localhost" --testServerHost+ , httpPort = port+ , httpProtocolId = protId+ , httpResponseTimeout = Nothing+ }++mkServerTest+ :: String+ -> String+ -> ProtocolId+ -> Thrift Echoer ()+ -> Test+mkServerTest pname label protId action =+ TestLabel (pname ++ " " ++ label) $ TestCase $+ withTestServer defaultOptions $ \port -> do+ let httpConf = mkHTTPConfig port protId+ withHTTPChannel httpConf action++-- Calculator function+addTest :: String -> ProtocolId -> Test+addTest pname protId = mkServerTest pname "add test" protId $ do+ res <- add 5 2+ lift $ assertEqual "5 + 2 = 7" 7 res++-- Calculator function+divideTest :: String -> ProtocolId -> Test+divideTest pname protId = mkServerTest pname "divide test" protId $ do+ res <- divide 9 3+ lift $ assertEqual "9 / 3 = 3" 3 res++divideExceptionTest :: String -> ProtocolId -> Test+divideExceptionTest pname protId =+ mkServerTest pname "divide exception" protId $+ (void . lift . evaluate =<< divide 1 0)+ `catchThrift` \DivideByZero -> return ()++-- Calculator function+multiTest :: String -> ProtocolId -> Test+multiTest pname protId = mkServerTest pname "multiple requests" protId $ do+ put 100++ r1 <- add 2 2+ lift $ assertEqual "2 + 2 = 4" 4 r1++ r2 <- divide 64 16+ lift $ assertEqual "64 / 16 = 4" 4 r2++ r3 <- get+ lift $ assertEqual "put = get" 100 r3++ r4 <- divide 100 10+ lift $ assertEqual "100 / 10 = 10" 10 r4++unimplementedTest :: String -> ProtocolId -> Test+unimplementedTest pname protId =+ mkServerTest pname "unimplemented test" protId $+ unimplemented `catchThrift` \ApplicationException{} -> return ()++-- Echo function+echoTest :: String -> ProtocolId -> Test+echoTest pname protId = mkServerTest pname "echo" protId $ do+ res <- echo val+ lift $ assertEqual "echo echoed" val res+ where+ val = "AAAAAAAAAA_DO_NOT_DELETE"++portAlreadyBoundTest :: String -> ProtocolId -> Test+portAlreadyBoundTest pname protId =+ TestLabel (pname ++ " portAlreadyBoundTest") $ TestCase $ do+ (result :: Either SomeException ()) <- try $+ withTestServer serverOptions $ const $ do+ withHTTPChannel httpConfig $+ lift $ withTestServer serverOptions $ const $ do+ withHTTPChannel httpConfig $+ return ()+ assertBool "should fail" (isLeft result)+ where+ port :: Int+ port = 9999+ serverOptions :: ServerOptions+ serverOptions = defaultOptions+ { desiredPort = Just port+ }+ httpConfig :: HTTPConfig t+ httpConfig = mkHTTPConfig port protId++tests :: String -> ProtocolId -> [Test]+tests pname protId = map (\f -> f pname protId)+ [ addTest+ , divideTest+ , divideExceptionTest+ , multiTest+ , unimplementedTest+ , echoTest+ , portAlreadyBoundTest+ ]++main :: IO ()+main = withFacebookUnitTest $+ testRunner $ TestList $+ tests "compact" compactProtocolId +++ tests "binary" binaryProtocolId
+ test/common/CalculatorHandler.hs view
@@ -0,0 +1,43 @@+{-+ 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 CalculatorHandler+ ( calculatorHandler+ , CalculatorState+ , initCalcState+ ) where++import Control.Exception (throw)+import Data.IORef+import Thrift.Protocol.ApplicationException.Types++import Math.Types+import Math.Adder.Service+import Math.Calculator.Service++newtype CalculatorState = CalculatorState (IORef Int)++initCalcState :: IO CalculatorState+initCalcState = do+ r <- newIORef 0+ return $ CalculatorState r++calculatorHandler :: CalculatorState -> CalculatorCommand a -> IO a+calculatorHandler _ (SuperAdder (Add x y)) = return $ x + y+calculatorHandler _ (Divide x y)+ | y == 0 = throw DivideByZero+ | otherwise = return $ x / y+calculatorHandler (CalculatorState ref) (Put v) =+ writeIORef ref (fromIntegral v)+calculatorHandler (CalculatorState ref) (PutMany v) =+ mapM_ (writeIORef ref . fromIntegral) v+calculatorHandler (CalculatorState ref) Get =+ fromIntegral <$> readIORef ref+calculatorHandler _ Unimplemented =+ throw $ ApplicationException "Unimplemented function"+ ApplicationExceptionType_UnknownMethod
+ test/common/EchoHandler.hs view
@@ -0,0 +1,27 @@+{-+ 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 EchoHandler+ ( echoHandler++ , EchoerState+ , initEchoerState+ ) where++import CalculatorHandler++import Echoer.Echoer.Service++newtype EchoerState = EchoerState CalculatorState++initEchoerState :: IO EchoerState+initEchoerState = EchoerState <$> initCalcState++echoHandler :: EchoerState -> EchoerCommand a -> IO a+echoHandler _ (Echo input) = return input+echoHandler (EchoerState c) (SuperCalculator x) = calculatorHandler c x
+ test/gen-hs2/Echoer/Echoer/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 Echoer.Echoer.Client+ (Echoer, echo, echoIO, send_echo, _build_echo, recv_echo,+ _parse_echo)+ 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 Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Math.Calculator.Client as Calculator+import qualified Math.Types as Math+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 Echoer.Types++data Echoer++type instance Thrift.Super Echoer = Calculator.Calculator++echo ::+ (Thrift.Protocol p, Thrift.ClientChannel c,+ (Thrift.<:) s Echoer) =>+ Text.Text -> Thrift.ThriftM p c s Text.Text+echo __field__input+ = do Thrift.ThriftEnv _proxy _channel _opts _counter <- Reader.ask+ Trans.lift (echoIO _proxy _channel _counter _opts __field__input)++echoIO ::+ (Thrift.Protocol p, Thrift.ClientChannel c,+ (Thrift.<:) s Echoer) =>+ Proxy.Proxy p ->+ c s ->+ Thrift.Counter ->+ Thrift.RpcOptions -> Text.Text -> Prelude.IO Text.Text+echoIO _proxy _channel _counter _opts __field__input+ = do (_handle, _sendCob, _recvCob) <- Thrift.mkCallbacks+ (recv_echo _proxy)+ send_echo _proxy _channel _counter _sendCob _recvCob _opts+ __field__input+ Thrift.wait _handle++send_echo ::+ (Thrift.Protocol p, Thrift.ClientChannel c,+ (Thrift.<:) s Echoer) =>+ Proxy.Proxy p ->+ c s ->+ Thrift.Counter ->+ Thrift.SendCallback ->+ Thrift.RecvCallback ->+ Thrift.RpcOptions -> Text.Text -> Prelude.IO ()+send_echo _proxy _channel _counter _sendCob _recvCob _rpcOpts+ __field__input+ = do _seqNum <- _counter+ let+ _callMsg+ = LBS.toStrict+ (ByteString.toLazyByteString+ (_build_echo _proxy _seqNum __field__input))+ Thrift.sendRequest _channel+ (Thrift.Request _callMsg+ (Thrift.setRpcPriority _rpcOpts Thrift.NormalPriority))+ _sendCob+ _recvCob++recv_echo ::+ (Thrift.Protocol p) =>+ Proxy.Proxy p ->+ Thrift.Response -> Prelude.Either Exception.SomeException Text.Text+recv_echo _proxy (Thrift.Response _response _)+ = Monad.join+ (Arrow.left (Exception.SomeException . Thrift.ProtocolException)+ (Parser.parse (_parse_echo _proxy) _response))++_build_echo ::+ Thrift.Protocol p =>+ Proxy.Proxy p -> Int.Int32 -> Text.Text -> ByteString.Builder+_build_echo _proxy _seqNum __field__input+ = Thrift.genMsgBegin _proxy "echo" 1 _seqNum <>+ Thrift.genStruct _proxy+ (Thrift.genField _proxy "input" (Thrift.getStringType _proxy) 1 0+ (Thrift.genText _proxy __field__input)+ : [])+ <> Thrift.genMsgEnd _proxy++_parse_echo ::+ Thrift.Protocol p =>+ Proxy.Proxy p ->+ Parser.Parser (Prelude.Either Exception.SomeException Text.Text)+_parse_echo _proxy+ = do Thrift.MsgBegin _name _msgTy _ <- Thrift.parseMsgBegin _proxy+ _result <- case _msgTy of+ 1 -> Prelude.fail "echo: expected reply but got function call"+ 2 | _name == "echo" ->+ do let+ _idMap = HashMap.fromList [("echo_success", 0)]+ _fieldBegin <- Thrift.parseFieldBegin _proxy 0 _idMap+ case _fieldBegin of+ Thrift.FieldBegin _type _id _bool -> do case _id of+ 0 | _type ==+ Thrift.getStringType+ _proxy+ ->+ Prelude.fmap+ Prelude.Right+ (Thrift.parseText+ _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+ "echo: expected reply but got oneway function call"+ _ -> Prelude.fail "echo: invalid message type"+ Thrift.parseMsgEnd _proxy+ Prelude.return _result
+ test/gen-hs2/Echoer/Echoer/Service.hs view
@@ -0,0 +1,132 @@+-----------------------------------------------------------------+-- 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 Echoer.Echoer.Service+ (EchoerCommand(..), 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 Data.Text.Encoding as Text+import qualified Echoer.Types as Types+import qualified Math.Calculator.Service as Calculator+import qualified Math.Types as Math+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 EchoerCommand a where+ Echo :: Text.Text -> EchoerCommand Text.Text+ SuperCalculator ::+ Calculator.CalculatorCommand a -> EchoerCommand a++instance Thrift.Processor EchoerCommand where+ reqName = reqName'+ reqParser = reqParser'+ respWriter = respWriter'+ methodsInfo _ = methodsInfo'++reqName' :: EchoerCommand a -> Text.Text+reqName' (Echo __field__input) = "echo"+reqName' (SuperCalculator x) = Calculator.reqName' x++reqParser' ::+ Thrift.Protocol p =>+ Proxy.Proxy p ->+ Text.Text -> Parser.Parser (Thrift.Some EchoerCommand)+reqParser' _proxy "echo"+ = ST.runSTT+ (do Prelude.return ()+ __field__input <- ST.newSTRef ""+ 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__input+ _val+ _ -> Trans.lift+ (Thrift.parseSkip _proxy _type+ (Prelude.Just _bool))+ _parse _id+ Thrift.FieldEnd -> do !__val__input <- ST.readSTRef __field__input+ Prelude.pure (Thrift.Some (Echo __val__input))+ _idMap = HashMap.fromList [("input", 1)]+ _parse 0)+reqParser' _proxy funName+ = do Thrift.Some x <- Calculator.reqParser' _proxy funName+ Prelude.return (Thrift.Some (SuperCalculator x))++respWriter' ::+ Thrift.Protocol p =>+ Proxy.Proxy p ->+ Int.Int32 ->+ EchoerCommand a ->+ Prelude.Either Exception.SomeException a ->+ (Builder.Builder,+ Prelude.Maybe (Exception.SomeException, Thrift.Blame))+respWriter' _proxy _seqNum Echo{} _r+ = (Thrift.genMsgBegin _proxy "echo" _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.getStringType _proxy) 0 0+ (Thrift.genText _proxy _result)],+ Prelude.Nothing)+respWriter' _proxy _seqNum (SuperCalculator _x) _r+ = Calculator.respWriter' _proxy _seqNum _x _r++methodsInfo' :: Map.Map Text.Text Thrift.MethodInfo+methodsInfo'+ = Map.union+ (Map.fromList+ [("echo", Thrift.MethodInfo Thrift.NormalPriority Prelude.False)])+ Calculator.methodsInfo'
+ test/gen-hs2/Echoer/Types.hs view
@@ -0,0 +1,18 @@+-----------------------------------------------------------------+-- 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 Echoer.Types () where+import qualified Math.Types as Math+import qualified Prelude as Prelude+import qualified Thrift.CodegenTypesOnly as Thrift
+ 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
+ thrift-http.cabal view
@@ -0,0 +1,151 @@+cabal-version: 3.6++-- Copyright (c) Facebook, Inc. and its affiliates.++name: thrift-http+version: 0.1.0.1+synopsis: Support for Thrift-over-HTTP server and client+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++description:+ Support for building servers and clients that communicate+ using Thrift over an HTTP transport. Uses WAI and Warp as+ the server-side HTTP implementation, and http-client for+ the client-side implementation.++ This transport is only compatible with itself. In particular, it+ is *not* compatible with fbthrift or apache-thrift clients and+ servers.++ 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+ if flag(opt)+ ghc-options: -O2++flag opt+ default: False++library+ import: fb-haskell+ exposed-modules:+ Thrift.Server.HTTP+ Thrift.Channel.HTTP++ build-depends:+ fb-util >= 0.1.0 && < 0.2,+ thrift-lib >= 0.1.0 && < 0.2,+ base >=4.11.1 && <4.20,+ text ^>=1.2.3.0,+ bytestring >=0.10.8.2 && <0.13,+ async ^>=2.2.1,+ utf8-string >= 1.0.2 && < 1.1,+ containers >= 0.6 && < 0.7,+ wai >= 3.2.4 && < 3.3,+ warp >= 3.3.30 && < 3.5,+ streaming-commons >= 0.2.2 && < 0.3,+ network >= 3.2.7 && < 3.3,+ http-client >= 0.7.18 && < 0.8,+ http-types >= 0.12.4 && < 0.13++ default-language: Haskell2010++-- Workaround for IPv6 loopback bug on Docker/Ubuntu:+-- https://github.com/docker/for-linux/issues/1374+flag tests_use_ipv4+ description: Force tests to use IPV4 whenever bringing thrift clients/servers up+ default: False+ manual: True++common test-deps+ build-depends:+ base >=4.11.1 && <4.20,+ aeson >= 2.0.3 && < 2.3,+ bytestring,+ data-default >= 0.8.0 && < 0.9,+ deepseq >= 1.4.4 && < 1.6,+ fb-stubs >= 0.1.0 && < 0.2,+ fb-util,+ hashable >= 1.4.4 && < 1.5,+ hspec >= 2.11.10 && < 2.12,+ hspec-contrib >= 0.5.2 && < 0.6,+ ghc-prim >= 0.5.3 && < 0.12,+ HUnit ^>= 1.6.1,+ STMonadTrans >= 0.4.8 && < 0.5,+ text,+ thrift-lib,+ thrift-lib:test-helpers,+ transformers >= 0.5.6 && < 0.7,+ unordered-containers >= 0.2.20 && < 0.3++ if flag(tests_use_ipv4)+ -- for test/Network.hs+ cpp-options: -DIPV4++library test-lib+ import: fb-haskell, test-deps+ hs-source-dirs: test/common, test/gen-hs2+ exposed-modules:+ CalculatorHandler+ EchoHandler+ Echoer.Echoer.Client+ Echoer.Echoer.Service+ Echoer.Types+ Math.Adder.Client+ Math.Adder.Service+ Math.Calculator.Client+ Math.Calculator.Service+ Math.Types+ build-depends:+ containers++common test-common+ import: test-deps+ hs-source-dirs: test+ build-depends: thrift-http:test-lib, thrift-http+ ghc-options: -threaded++test-suite server+ import: fb-haskell, test-common+ type: exitcode-stdio-1.0+ main-is: ServerTest.hs+ ghc-options: -main-is ServerTest