diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +BSD License + +For hsthrift software + +Copyright (c) Facebook, Inc. and its affiliates. All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + * Neither the name Facebook nor the names of its contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Thrift/Channel/HTTP.hs b/Thrift/Channel/HTTP.hs new file mode 100644 --- /dev/null +++ b/Thrift/Channel/HTTP.hs @@ -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)))) diff --git a/Thrift/Server/HTTP.hs b/Thrift/Server/HTTP.hs new file mode 100644 --- /dev/null +++ b/Thrift/Server/HTTP.hs @@ -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" diff --git a/test/ServerTest.hs b/test/ServerTest.hs new file mode 100644 --- /dev/null +++ b/test/ServerTest.hs @@ -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 diff --git a/test/common/CalculatorHandler.hs b/test/common/CalculatorHandler.hs new file mode 100644 --- /dev/null +++ b/test/common/CalculatorHandler.hs @@ -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 diff --git a/test/common/EchoHandler.hs b/test/common/EchoHandler.hs new file mode 100644 --- /dev/null +++ b/test/common/EchoHandler.hs @@ -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 diff --git a/test/gen-hs2/Echoer/Echoer/Client.hs b/test/gen-hs2/Echoer/Echoer/Client.hs new file mode 100644 --- /dev/null +++ b/test/gen-hs2/Echoer/Echoer/Client.hs @@ -0,0 +1,153 @@ +----------------------------------------------------------------- +-- Autogenerated by Thrift +-- +-- DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING +-- @generated +----------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports#-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-record-updates#-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module 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 diff --git a/test/gen-hs2/Echoer/Echoer/Service.hs b/test/gen-hs2/Echoer/Echoer/Service.hs new file mode 100644 --- /dev/null +++ b/test/gen-hs2/Echoer/Echoer/Service.hs @@ -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' diff --git a/test/gen-hs2/Echoer/Types.hs b/test/gen-hs2/Echoer/Types.hs new file mode 100644 --- /dev/null +++ b/test/gen-hs2/Echoer/Types.hs @@ -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 diff --git a/test/gen-hs2/Math/Adder/Client.hs b/test/gen-hs2/Math/Adder/Client.hs new file mode 100644 --- /dev/null +++ b/test/gen-hs2/Math/Adder/Client.hs @@ -0,0 +1,153 @@ +----------------------------------------------------------------- +-- Autogenerated by Thrift +-- +-- DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING +-- @generated +----------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports#-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-record-updates#-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Math.Adder.Client + (Adder, add, addIO, send_add, _build_add, recv_add, _parse_add) + where +import qualified Control.Arrow as Arrow +import qualified Control.Concurrent as Concurrent +import qualified Control.Exception as Exception +import qualified Control.Monad as Monad +import qualified Control.Monad.Trans.Class as Trans +import qualified Control.Monad.Trans.Reader as Reader +import qualified Data.ByteString.Builder as ByteString +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Int as Int +import qualified Data.List as List +import qualified Data.Proxy as Proxy +import qualified Prelude as Prelude +import qualified Thrift.Binary.Parser as Parser +import qualified Thrift.Codegen as Thrift +import qualified Thrift.Protocol.ApplicationException.Types + as Thrift +import Data.Monoid ((<>)) +import Prelude ((==), (=<<), (>>=), (<$>), (.)) +import Math.Types + +data Adder + +add :: + (Thrift.Protocol p, Thrift.ClientChannel c, (Thrift.<:) s Adder) => + Prelude.Int -> Prelude.Int -> Thrift.ThriftM p c s Prelude.Int +add __field__x __field__y + = do Thrift.ThriftEnv _proxy _channel _opts _counter <- Reader.ask + Trans.lift + (addIO _proxy _channel _counter _opts __field__x __field__y) + +addIO :: + (Thrift.Protocol p, Thrift.ClientChannel c, (Thrift.<:) s Adder) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.RpcOptions -> + Prelude.Int -> Prelude.Int -> Prelude.IO Prelude.Int +addIO _proxy _channel _counter _opts __field__x __field__y + = do (_handle, _sendCob, _recvCob) <- Thrift.mkCallbacks + (recv_add _proxy) + send_add _proxy _channel _counter _sendCob _recvCob _opts + __field__x + __field__y + Thrift.wait _handle + +send_add :: + (Thrift.Protocol p, Thrift.ClientChannel c, (Thrift.<:) s Adder) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.SendCallback -> + Thrift.RecvCallback -> + Thrift.RpcOptions -> Prelude.Int -> Prelude.Int -> Prelude.IO () +send_add _proxy _channel _counter _sendCob _recvCob _rpcOpts + __field__x __field__y + = do _seqNum <- _counter + let + _callMsg + = LBS.toStrict + (ByteString.toLazyByteString + (_build_add _proxy _seqNum __field__x __field__y)) + Thrift.sendRequest _channel + (Thrift.Request _callMsg + (Thrift.setRpcPriority _rpcOpts Thrift.NormalPriority)) + _sendCob + _recvCob + +recv_add :: + (Thrift.Protocol p) => + Proxy.Proxy p -> + Thrift.Response -> + Prelude.Either Exception.SomeException Prelude.Int +recv_add _proxy (Thrift.Response _response _) + = Monad.join + (Arrow.left (Exception.SomeException . Thrift.ProtocolException) + (Parser.parse (_parse_add _proxy) _response)) + +_build_add :: + Thrift.Protocol p => + Proxy.Proxy p -> + Int.Int32 -> Prelude.Int -> Prelude.Int -> ByteString.Builder +_build_add _proxy _seqNum __field__x __field__y + = Thrift.genMsgBegin _proxy "add" 1 _seqNum <> + Thrift.genStruct _proxy + (Thrift.genField _proxy "x" (Thrift.getI64Type _proxy) 1 0 + ((Thrift.genI64 _proxy . Prelude.fromIntegral) __field__x) + : + Thrift.genField _proxy "y" (Thrift.getI64Type _proxy) 2 1 + ((Thrift.genI64 _proxy . Prelude.fromIntegral) __field__y) + : []) + <> Thrift.genMsgEnd _proxy + +_parse_add :: + Thrift.Protocol p => + Proxy.Proxy p -> + Parser.Parser (Prelude.Either Exception.SomeException Prelude.Int) +_parse_add _proxy + = do Thrift.MsgBegin _name _msgTy _ <- Thrift.parseMsgBegin _proxy + _result <- case _msgTy of + 1 -> Prelude.fail "add: expected reply but got function call" + 2 | _name == "add" -> + do let + _idMap = HashMap.fromList [("add_success", 0)] + _fieldBegin <- Thrift.parseFieldBegin _proxy 0 _idMap + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 0 | _type == + Thrift.getI64Type + _proxy + -> + Prelude.fmap + Prelude.Right + (Prelude.fromIntegral + <$> + Thrift.parseI64 + _proxy) + _ -> Prelude.fail + (Prelude.unwords + ["unrecognized exception, type:", + Prelude.show + _type, + "field id:", + Prelude.show _id]) + Thrift.FieldEnd -> Prelude.fail "no response" + | Prelude.otherwise -> Prelude.fail "reply function does not match" + 3 -> Prelude.fmap (Prelude.Left . Exception.SomeException) + (Thrift.parseStruct _proxy :: + Parser.Parser Thrift.ApplicationException) + 4 -> Prelude.fail + "add: expected reply but got oneway function call" + _ -> Prelude.fail "add: invalid message type" + Thrift.parseMsgEnd _proxy + Prelude.return _result diff --git a/test/gen-hs2/Math/Adder/Service.hs b/test/gen-hs2/Math/Adder/Service.hs new file mode 100644 --- /dev/null +++ b/test/gen-hs2/Math/Adder/Service.hs @@ -0,0 +1,131 @@ +----------------------------------------------------------------- +-- Autogenerated by Thrift +-- +-- DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING +-- @generated +----------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports#-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-record-updates#-} +{-# LANGUAGE GADTs #-} +module Math.Adder.Service + (AdderCommand(..), reqName', reqParser', respWriter', methodsInfo') + where +import qualified Control.Exception as Exception +import qualified Control.Monad.ST.Trans as ST +import qualified Control.Monad.Trans.Class as Trans +import qualified Data.ByteString.Builder as Builder +import qualified Data.Default as Default +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Int as Int +import qualified Data.Map.Strict as Map +import qualified Data.Proxy as Proxy +import qualified Data.Text as Text +import qualified Math.Types as Types +import qualified Prelude as Prelude +import qualified Thrift.Binary.Parser as Parser +import qualified Thrift.Codegen as Thrift +import qualified Thrift.Processor as Thrift +import qualified Thrift.Protocol.ApplicationException.Types + as Thrift +import Control.Applicative ((<*), (*>)) +import Data.Monoid ((<>)) +import Prelude ((<$>), (<*>), (++), (.), (==)) + +data AdderCommand a where + Add :: Prelude.Int -> Prelude.Int -> AdderCommand Prelude.Int + +instance Thrift.Processor AdderCommand where + reqName = reqName' + reqParser = reqParser' + respWriter = respWriter' + methodsInfo _ = methodsInfo' + +reqName' :: AdderCommand a -> Text.Text +reqName' (Add __field__x __field__y) = "add" + +reqParser' :: + Thrift.Protocol p => + Proxy.Proxy p -> + Text.Text -> Parser.Parser (Thrift.Some AdderCommand) +reqParser' _proxy "add" + = ST.runSTT + (do Prelude.return () + __field__x <- ST.newSTRef Default.def + __field__y <- ST.newSTRef Default.def + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 1 | _type == Thrift.getI64Type _proxy + -> + do !_val <- Trans.lift + (Prelude.fromIntegral + <$> + Thrift.parseI64 + _proxy) + ST.writeSTRef __field__x _val + 2 | _type == Thrift.getI64Type _proxy + -> + do !_val <- Trans.lift + (Prelude.fromIntegral + <$> + Thrift.parseI64 + _proxy) + ST.writeSTRef __field__y _val + _ -> Trans.lift + (Thrift.parseSkip _proxy _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do !__val__x <- ST.readSTRef __field__x + !__val__y <- ST.readSTRef __field__y + Prelude.pure (Thrift.Some (Add __val__x __val__y)) + _idMap = HashMap.fromList [("x", 1), ("y", 2)] + _parse 0) +reqParser' _ funName + = Prelude.errorWithoutStackTrace + ("unknown function call: " ++ Text.unpack funName) + +respWriter' :: + Thrift.Protocol p => + Proxy.Proxy p -> + Int.Int32 -> + AdderCommand a -> + Prelude.Either Exception.SomeException a -> + (Builder.Builder, + Prelude.Maybe (Exception.SomeException, Thrift.Blame)) +respWriter' _proxy _seqNum Add{} _r + = (Thrift.genMsgBegin _proxy "add" _msgType _seqNum <> _msgBody <> + Thrift.genMsgEnd _proxy, + _msgException) + where + (_msgType, _msgBody, _msgException) + = case _r of + Prelude.Left _ex | Prelude.Just + _e@Thrift.ApplicationException{} <- Exception.fromException _ex + -> + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (_ex, Thrift.ServerError)) + | Prelude.otherwise -> + let _e + = Thrift.ApplicationException (Text.pack (Prelude.show _ex)) + Thrift.ApplicationExceptionType_InternalError + in + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (Exception.toException _e, Thrift.ServerError)) + Prelude.Right _result -> (2, + Thrift.genStruct _proxy + [Thrift.genField _proxy "" (Thrift.getI64Type _proxy) 0 0 + ((Thrift.genI64 _proxy . Prelude.fromIntegral) _result)], + Prelude.Nothing) + +methodsInfo' :: Map.Map Text.Text Thrift.MethodInfo +methodsInfo' + = Map.fromList + [("add", Thrift.MethodInfo Thrift.NormalPriority Prelude.False)] diff --git a/test/gen-hs2/Math/Calculator/Client.hs b/test/gen-hs2/Math/Calculator/Client.hs new file mode 100644 --- /dev/null +++ b/test/gen-hs2/Math/Calculator/Client.hs @@ -0,0 +1,598 @@ +----------------------------------------------------------------- +-- Autogenerated by Thrift +-- +-- DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING +-- @generated +----------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports#-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-record-updates#-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Math.Calculator.Client + (Calculator, divide, divideIO, send_divide, _build_divide, + recv_divide, _parse_divide, quotRem, quotRemIO, send_quotRem, + _build_quotRem, recv_quotRem, _parse_quotRem, put, putIO, send_put, + _build_put, putMany, putManyIO, send_putMany, _build_putMany, get, + getIO, send_get, _build_get, recv_get, _parse_get, unimplemented, + unimplementedIO, send_unimplemented, _build_unimplemented, + recv_unimplemented, _parse_unimplemented) + where +import qualified Control.Arrow as Arrow +import qualified Control.Concurrent as Concurrent +import qualified Control.Exception as Exception +import qualified Control.Monad as Monad +import qualified Control.Monad.Trans.Class as Trans +import qualified Control.Monad.Trans.Reader as Reader +import qualified Data.ByteString.Builder as ByteString +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Int as Int +import qualified Data.List as List +import qualified Data.Proxy as Proxy +import qualified Math.Adder.Client as Adder +import qualified Prelude as Prelude +import qualified Thrift.Binary.Parser as Parser +import qualified Thrift.Codegen as Thrift +import qualified Thrift.Protocol.ApplicationException.Types + as Thrift +import Data.Monoid ((<>)) +import Prelude ((==), (=<<), (>>=), (<$>), (.)) +import Math.Types + +data Calculator + +type instance Thrift.Super Calculator = Adder.Adder + +divide :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Prelude.Double -> + Prelude.Double -> Thrift.ThriftM p c s Prelude.Double +divide __field__dividend __field__divisor + = do Thrift.ThriftEnv _proxy _channel _opts _counter <- Reader.ask + Trans.lift + (divideIO _proxy _channel _counter _opts __field__dividend + __field__divisor) + +divideIO :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.RpcOptions -> + Prelude.Double -> Prelude.Double -> Prelude.IO Prelude.Double +divideIO _proxy _channel _counter _opts __field__dividend + __field__divisor + = do (_handle, _sendCob, _recvCob) <- Thrift.mkCallbacks + (recv_divide _proxy) + send_divide _proxy _channel _counter _sendCob _recvCob _opts + __field__dividend + __field__divisor + Thrift.wait _handle + +send_divide :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.SendCallback -> + Thrift.RecvCallback -> + Thrift.RpcOptions -> + Prelude.Double -> Prelude.Double -> Prelude.IO () +send_divide _proxy _channel _counter _sendCob _recvCob _rpcOpts + __field__dividend __field__divisor + = do _seqNum <- _counter + let + _callMsg + = LBS.toStrict + (ByteString.toLazyByteString + (_build_divide _proxy _seqNum __field__dividend __field__divisor)) + Thrift.sendRequest _channel + (Thrift.Request _callMsg + (Thrift.setRpcPriority _rpcOpts Thrift.NormalPriority)) + _sendCob + _recvCob + +recv_divide :: + (Thrift.Protocol p) => + Proxy.Proxy p -> + Thrift.Response -> + Prelude.Either Exception.SomeException Prelude.Double +recv_divide _proxy (Thrift.Response _response _) + = Monad.join + (Arrow.left (Exception.SomeException . Thrift.ProtocolException) + (Parser.parse (_parse_divide _proxy) _response)) + +_build_divide :: + Thrift.Protocol p => + Proxy.Proxy p -> + Int.Int32 -> Prelude.Double -> Prelude.Double -> ByteString.Builder +_build_divide _proxy _seqNum __field__dividend __field__divisor + = Thrift.genMsgBegin _proxy "divide" 1 _seqNum <> + Thrift.genStruct _proxy + (Thrift.genField _proxy "dividend" (Thrift.getDoubleType _proxy) 1 + 0 + (Thrift.genDouble _proxy __field__dividend) + : + Thrift.genField _proxy "divisor" (Thrift.getDoubleType _proxy) 2 1 + (Thrift.genDouble _proxy __field__divisor) + : []) + <> Thrift.genMsgEnd _proxy + +_parse_divide :: + Thrift.Protocol p => + Proxy.Proxy p -> + Parser.Parser + (Prelude.Either Exception.SomeException Prelude.Double) +_parse_divide _proxy + = do Thrift.MsgBegin _name _msgTy _ <- Thrift.parseMsgBegin _proxy + _result <- case _msgTy of + 1 -> Prelude.fail "divide: expected reply but got function call" + 2 | _name == "divide" -> + do let + _idMap + = HashMap.fromList [("divide_success", 0), ("divisionError", 1)] + _fieldBegin <- Thrift.parseFieldBegin _proxy 0 _idMap + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 0 | _type == + Thrift.getDoubleType + _proxy + -> + Prelude.fmap + Prelude.Right + (Thrift.parseDouble + _proxy) + 1 | _type == + Thrift.getStructType + _proxy + -> + Prelude.fmap + (Prelude.Left . + Exception.SomeException) + (Thrift.parseStruct + _proxy + :: + Parser.Parser + DivideByZero) + _ -> Prelude.fail + (Prelude.unwords + ["unrecognized exception, type:", + Prelude.show + _type, + "field id:", + Prelude.show _id]) + Thrift.FieldEnd -> Prelude.fail "no response" + | Prelude.otherwise -> Prelude.fail "reply function does not match" + 3 -> Prelude.fmap (Prelude.Left . Exception.SomeException) + (Thrift.parseStruct _proxy :: + Parser.Parser Thrift.ApplicationException) + 4 -> Prelude.fail + "divide: expected reply but got oneway function call" + _ -> Prelude.fail "divide: invalid message type" + Thrift.parseMsgEnd _proxy + Prelude.return _result + +quotRem :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Prelude.Int -> Prelude.Int -> Thrift.ThriftM p c s QuotRemResponse +quotRem __field__dividend __field__divisor + = do Thrift.ThriftEnv _proxy _channel _opts _counter <- Reader.ask + Trans.lift + (quotRemIO _proxy _channel _counter _opts __field__dividend + __field__divisor) + +quotRemIO :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.RpcOptions -> + Prelude.Int -> Prelude.Int -> Prelude.IO QuotRemResponse +quotRemIO _proxy _channel _counter _opts __field__dividend + __field__divisor + = do (_handle, _sendCob, _recvCob) <- Thrift.mkCallbacks + (recv_quotRem _proxy) + send_quotRem _proxy _channel _counter _sendCob _recvCob _opts + __field__dividend + __field__divisor + Thrift.wait _handle + +send_quotRem :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.SendCallback -> + Thrift.RecvCallback -> + Thrift.RpcOptions -> Prelude.Int -> Prelude.Int -> Prelude.IO () +send_quotRem _proxy _channel _counter _sendCob _recvCob _rpcOpts + __field__dividend __field__divisor + = do _seqNum <- _counter + let + _callMsg + = LBS.toStrict + (ByteString.toLazyByteString + (_build_quotRem _proxy _seqNum __field__dividend __field__divisor)) + Thrift.sendRequest _channel + (Thrift.Request _callMsg + (Thrift.setRpcPriority _rpcOpts Thrift.NormalPriority)) + _sendCob + _recvCob + +recv_quotRem :: + (Thrift.Protocol p) => + Proxy.Proxy p -> + Thrift.Response -> + Prelude.Either Exception.SomeException QuotRemResponse +recv_quotRem _proxy (Thrift.Response _response _) + = Monad.join + (Arrow.left (Exception.SomeException . Thrift.ProtocolException) + (Parser.parse (_parse_quotRem _proxy) _response)) + +_build_quotRem :: + Thrift.Protocol p => + Proxy.Proxy p -> + Int.Int32 -> Prelude.Int -> Prelude.Int -> ByteString.Builder +_build_quotRem _proxy _seqNum __field__dividend __field__divisor + = Thrift.genMsgBegin _proxy "quotRem" 1 _seqNum <> + Thrift.genStruct _proxy + (Thrift.genField _proxy "dividend" (Thrift.getI64Type _proxy) 1 0 + ((Thrift.genI64 _proxy . Prelude.fromIntegral) __field__dividend) + : + Thrift.genField _proxy "divisor" (Thrift.getI64Type _proxy) 2 1 + ((Thrift.genI64 _proxy . Prelude.fromIntegral) __field__divisor) + : []) + <> Thrift.genMsgEnd _proxy + +_parse_quotRem :: + Thrift.Protocol p => + Proxy.Proxy p -> + Parser.Parser + (Prelude.Either Exception.SomeException QuotRemResponse) +_parse_quotRem _proxy + = do Thrift.MsgBegin _name _msgTy _ <- Thrift.parseMsgBegin _proxy + _result <- case _msgTy of + 1 -> Prelude.fail "quotRem: expected reply but got function call" + 2 | _name == "quotRem" -> + do let + _idMap = HashMap.fromList [("quotRem_success", 0)] + _fieldBegin <- Thrift.parseFieldBegin _proxy 0 _idMap + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 0 | _type == + Thrift.getStructType + _proxy + -> + Prelude.fmap + Prelude.Right + (Thrift.parseStruct + _proxy) + _ -> Prelude.fail + (Prelude.unwords + ["unrecognized exception, type:", + Prelude.show + _type, + "field id:", + Prelude.show _id]) + Thrift.FieldEnd -> Prelude.fail "no response" + | Prelude.otherwise -> Prelude.fail "reply function does not match" + 3 -> Prelude.fmap (Prelude.Left . Exception.SomeException) + (Thrift.parseStruct _proxy :: + Parser.Parser Thrift.ApplicationException) + 4 -> Prelude.fail + "quotRem: expected reply but got oneway function call" + _ -> Prelude.fail "quotRem: invalid message type" + Thrift.parseMsgEnd _proxy + Prelude.return _result + +put :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Prelude.Int -> Thrift.ThriftM p c s () +put __field__val + = do Thrift.ThriftEnv _proxy _channel _opts _counter <- Reader.ask + Trans.lift (putIO _proxy _channel _counter _opts __field__val) + +putIO :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> Thrift.RpcOptions -> Prelude.Int -> Prelude.IO () +putIO _proxy _channel _counter _opts __field__val + = do _handle <- Concurrent.newEmptyMVar + send_put _proxy _channel _counter (Concurrent.putMVar _handle) + _opts + __field__val + Concurrent.takeMVar _handle >>= + Prelude.maybe (Prelude.return ()) Exception.throw + +send_put :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.SendCallback -> + Thrift.RpcOptions -> Prelude.Int -> Prelude.IO () +send_put _proxy _channel _counter _sendCob _rpcOpts __field__val + = do _seqNum <- _counter + let + _callMsg + = LBS.toStrict + (ByteString.toLazyByteString + (_build_put _proxy _seqNum __field__val)) + Thrift.sendOnewayRequest _channel + (Thrift.Request _callMsg + (Thrift.setRpcPriority _rpcOpts Thrift.NormalPriority)) + _sendCob + +_build_put :: + Thrift.Protocol p => + Proxy.Proxy p -> Int.Int32 -> Prelude.Int -> ByteString.Builder +_build_put _proxy _seqNum __field__val + = Thrift.genMsgBegin _proxy "put" 1 _seqNum <> + Thrift.genStruct _proxy + (Thrift.genField _proxy "val" (Thrift.getI64Type _proxy) 1 0 + ((Thrift.genI64 _proxy . Prelude.fromIntegral) __field__val) + : []) + <> Thrift.genMsgEnd _proxy + +putMany :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + [Prelude.Int] -> Thrift.ThriftM p c s () +putMany __field__val + = do Thrift.ThriftEnv _proxy _channel _opts _counter <- Reader.ask + Trans.lift (putManyIO _proxy _channel _counter _opts __field__val) + +putManyIO :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.RpcOptions -> [Prelude.Int] -> Prelude.IO () +putManyIO _proxy _channel _counter _opts __field__val + = do _handle <- Concurrent.newEmptyMVar + send_putMany _proxy _channel _counter (Concurrent.putMVar _handle) + _opts + __field__val + Concurrent.takeMVar _handle >>= + Prelude.maybe (Prelude.return ()) Exception.throw + +send_putMany :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.SendCallback -> + Thrift.RpcOptions -> [Prelude.Int] -> Prelude.IO () +send_putMany _proxy _channel _counter _sendCob _rpcOpts + __field__val + = do _seqNum <- _counter + let + _callMsg + = LBS.toStrict + (ByteString.toLazyByteString + (_build_putMany _proxy _seqNum __field__val)) + Thrift.sendOnewayRequest _channel + (Thrift.Request _callMsg + (Thrift.setRpcPriority _rpcOpts Thrift.NormalPriority)) + _sendCob + +_build_putMany :: + Thrift.Protocol p => + Proxy.Proxy p -> Int.Int32 -> [Prelude.Int] -> ByteString.Builder +_build_putMany _proxy _seqNum __field__val + = Thrift.genMsgBegin _proxy "putMany" 1 _seqNum <> + Thrift.genStruct _proxy + (Thrift.genField _proxy "val" (Thrift.getListType _proxy) 1 0 + (Thrift.genList _proxy (Thrift.getI64Type _proxy) + (Thrift.genI64 _proxy . Prelude.fromIntegral) + __field__val) + : []) + <> Thrift.genMsgEnd _proxy + +get :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Thrift.ThriftM p c s Prelude.Int +get + = do Thrift.ThriftEnv _proxy _channel _opts _counter <- Reader.ask + Trans.lift (getIO _proxy _channel _counter _opts) + +getIO :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> Thrift.RpcOptions -> Prelude.IO Prelude.Int +getIO _proxy _channel _counter _opts + = do (_handle, _sendCob, _recvCob) <- Thrift.mkCallbacks + (recv_get _proxy) + send_get _proxy _channel _counter _sendCob _recvCob _opts + Thrift.wait _handle + +send_get :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.SendCallback -> + Thrift.RecvCallback -> Thrift.RpcOptions -> Prelude.IO () +send_get _proxy _channel _counter _sendCob _recvCob _rpcOpts + = do _seqNum <- _counter + let + _callMsg + = LBS.toStrict + (ByteString.toLazyByteString (_build_get _proxy _seqNum)) + Thrift.sendRequest _channel + (Thrift.Request _callMsg + (Thrift.setRpcPriority _rpcOpts Thrift.NormalPriority)) + _sendCob + _recvCob + +recv_get :: + (Thrift.Protocol p) => + Proxy.Proxy p -> + Thrift.Response -> + Prelude.Either Exception.SomeException Prelude.Int +recv_get _proxy (Thrift.Response _response _) + = Monad.join + (Arrow.left (Exception.SomeException . Thrift.ProtocolException) + (Parser.parse (_parse_get _proxy) _response)) + +_build_get :: + Thrift.Protocol p => + Proxy.Proxy p -> Int.Int32 -> ByteString.Builder +_build_get _proxy _seqNum + = Thrift.genMsgBegin _proxy "get" 1 _seqNum <> + Thrift.genStruct _proxy [] + <> Thrift.genMsgEnd _proxy + +_parse_get :: + Thrift.Protocol p => + Proxy.Proxy p -> + Parser.Parser (Prelude.Either Exception.SomeException Prelude.Int) +_parse_get _proxy + = do Thrift.MsgBegin _name _msgTy _ <- Thrift.parseMsgBegin _proxy + _result <- case _msgTy of + 1 -> Prelude.fail "get: expected reply but got function call" + 2 | _name == "get" -> + do let + _idMap = HashMap.fromList [("get_success", 0)] + _fieldBegin <- Thrift.parseFieldBegin _proxy 0 _idMap + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 0 | _type == + Thrift.getI64Type + _proxy + -> + Prelude.fmap + Prelude.Right + (Prelude.fromIntegral + <$> + Thrift.parseI64 + _proxy) + _ -> Prelude.fail + (Prelude.unwords + ["unrecognized exception, type:", + Prelude.show + _type, + "field id:", + Prelude.show _id]) + Thrift.FieldEnd -> Prelude.fail "no response" + | Prelude.otherwise -> Prelude.fail "reply function does not match" + 3 -> Prelude.fmap (Prelude.Left . Exception.SomeException) + (Thrift.parseStruct _proxy :: + Parser.Parser Thrift.ApplicationException) + 4 -> Prelude.fail + "get: expected reply but got oneway function call" + _ -> Prelude.fail "get: invalid message type" + Thrift.parseMsgEnd _proxy + Prelude.return _result + +unimplemented :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Thrift.ThriftM p c s () +unimplemented + = do Thrift.ThriftEnv _proxy _channel _opts _counter <- Reader.ask + Trans.lift (unimplementedIO _proxy _channel _counter _opts) + +unimplementedIO :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> Thrift.Counter -> Thrift.RpcOptions -> Prelude.IO () +unimplementedIO _proxy _channel _counter _opts + = do (_handle, _sendCob, _recvCob) <- Thrift.mkCallbacks + (recv_unimplemented _proxy) + send_unimplemented _proxy _channel _counter _sendCob _recvCob _opts + Thrift.wait _handle + +send_unimplemented :: + (Thrift.Protocol p, Thrift.ClientChannel c, + (Thrift.<:) s Calculator) => + Proxy.Proxy p -> + c s -> + Thrift.Counter -> + Thrift.SendCallback -> + Thrift.RecvCallback -> Thrift.RpcOptions -> Prelude.IO () +send_unimplemented _proxy _channel _counter _sendCob _recvCob + _rpcOpts + = do _seqNum <- _counter + let + _callMsg + = LBS.toStrict + (ByteString.toLazyByteString (_build_unimplemented _proxy _seqNum)) + Thrift.sendRequest _channel + (Thrift.Request _callMsg + (Thrift.setRpcPriority _rpcOpts Thrift.NormalPriority)) + _sendCob + _recvCob + +recv_unimplemented :: + (Thrift.Protocol p) => + Proxy.Proxy p -> + Thrift.Response -> Prelude.Either Exception.SomeException () +recv_unimplemented _proxy (Thrift.Response _response _) + = Monad.join + (Arrow.left (Exception.SomeException . Thrift.ProtocolException) + (Parser.parse (_parse_unimplemented _proxy) _response)) + +_build_unimplemented :: + Thrift.Protocol p => + Proxy.Proxy p -> Int.Int32 -> ByteString.Builder +_build_unimplemented _proxy _seqNum + = Thrift.genMsgBegin _proxy "unimplemented" 1 _seqNum <> + Thrift.genStruct _proxy [] + <> Thrift.genMsgEnd _proxy + +_parse_unimplemented :: + Thrift.Protocol p => + Proxy.Proxy p -> + Parser.Parser (Prelude.Either Exception.SomeException ()) +_parse_unimplemented _proxy + = do Thrift.MsgBegin _name _msgTy _ <- Thrift.parseMsgBegin _proxy + _result <- case _msgTy of + 1 -> Prelude.fail + "unimplemented: expected reply but got function call" + 2 | _name == "unimplemented" -> + do let + _idMap = HashMap.fromList [] + _fieldBegin <- Thrift.parseFieldBegin _proxy 0 _idMap + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + _ -> Prelude.fail + (Prelude.unwords + ["unrecognized exception, type:", + Prelude.show + _type, + "field id:", + Prelude.show _id]) + Thrift.FieldEnd -> Prelude.return (Prelude.Right ()) + | Prelude.otherwise -> Prelude.fail "reply function does not match" + 3 -> Prelude.fmap (Prelude.Left . Exception.SomeException) + (Thrift.parseStruct _proxy :: + Parser.Parser Thrift.ApplicationException) + 4 -> Prelude.fail + "unimplemented: expected reply but got oneway function call" + _ -> Prelude.fail "unimplemented: invalid message type" + Thrift.parseMsgEnd _proxy + Prelude.return _result diff --git a/test/gen-hs2/Math/Calculator/Service.hs b/test/gen-hs2/Math/Calculator/Service.hs new file mode 100644 --- /dev/null +++ b/test/gen-hs2/Math/Calculator/Service.hs @@ -0,0 +1,416 @@ +----------------------------------------------------------------- +-- Autogenerated by Thrift +-- +-- DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING +-- @generated +----------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports#-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-record-updates#-} +{-# LANGUAGE GADTs #-} +module Math.Calculator.Service + (CalculatorCommand(..), reqName', reqParser', respWriter', + methodsInfo') + where +import qualified Control.Exception as Exception +import qualified Control.Monad.ST.Trans as ST +import qualified Control.Monad.Trans.Class as Trans +import qualified Data.ByteString.Builder as Builder +import qualified Data.Default as Default +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Int as Int +import qualified Data.Map.Strict as Map +import qualified Data.Proxy as Proxy +import qualified Data.Text as Text +import qualified Math.Adder.Service as Adder +import qualified Math.Types as Types +import qualified Prelude as Prelude +import qualified Thrift.Binary.Parser as Parser +import qualified Thrift.Codegen as Thrift +import qualified Thrift.Processor as Thrift +import qualified Thrift.Protocol.ApplicationException.Types + as Thrift +import Control.Applicative ((<*), (*>)) +import Data.Monoid ((<>)) +import Prelude ((<$>), (<*>), (++), (.), (==)) + +data CalculatorCommand a where + Divide :: + Prelude.Double -> + Prelude.Double -> CalculatorCommand Prelude.Double + QuotRem :: + Prelude.Int -> + Prelude.Int -> CalculatorCommand Types.QuotRemResponse + Put :: Prelude.Int -> CalculatorCommand () + PutMany :: [Prelude.Int] -> CalculatorCommand () + Get :: CalculatorCommand Prelude.Int + Unimplemented :: CalculatorCommand () + SuperAdder :: Adder.AdderCommand a -> CalculatorCommand a + +instance Thrift.Processor CalculatorCommand where + reqName = reqName' + reqParser = reqParser' + respWriter = respWriter' + methodsInfo _ = methodsInfo' + +reqName' :: CalculatorCommand a -> Text.Text +reqName' (Divide __field__dividend __field__divisor) = "divide" +reqName' (QuotRem __field__dividend __field__divisor) = "quotRem" +reqName' (Put __field__val) = "put" +reqName' (PutMany __field__val) = "putMany" +reqName' Get = "get" +reqName' Unimplemented = "unimplemented" +reqName' (SuperAdder x) = Adder.reqName' x + +reqParser' :: + Thrift.Protocol p => + Proxy.Proxy p -> + Text.Text -> Parser.Parser (Thrift.Some CalculatorCommand) +reqParser' _proxy "divide" + = ST.runSTT + (do Prelude.return () + __field__dividend <- ST.newSTRef Default.def + __field__divisor <- ST.newSTRef Default.def + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 1 | _type == + Thrift.getDoubleType _proxy + -> + do !_val <- Trans.lift + (Thrift.parseDouble + _proxy) + ST.writeSTRef + __field__dividend + _val + 2 | _type == + Thrift.getDoubleType _proxy + -> + do !_val <- Trans.lift + (Thrift.parseDouble + _proxy) + ST.writeSTRef __field__divisor + _val + _ -> Trans.lift + (Thrift.parseSkip _proxy _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do !__val__dividend <- ST.readSTRef + __field__dividend + !__val__divisor <- ST.readSTRef __field__divisor + Prelude.pure + (Thrift.Some (Divide __val__dividend __val__divisor)) + _idMap = HashMap.fromList [("dividend", 1), ("divisor", 2)] + _parse 0) +reqParser' _proxy "quotRem" + = ST.runSTT + (do Prelude.return () + __field__dividend <- ST.newSTRef Default.def + __field__divisor <- ST.newSTRef Default.def + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 1 | _type == Thrift.getI64Type _proxy + -> + do !_val <- Trans.lift + (Prelude.fromIntegral + <$> + Thrift.parseI64 + _proxy) + ST.writeSTRef + __field__dividend + _val + 2 | _type == Thrift.getI64Type _proxy + -> + do !_val <- Trans.lift + (Prelude.fromIntegral + <$> + Thrift.parseI64 + _proxy) + ST.writeSTRef __field__divisor + _val + _ -> Trans.lift + (Thrift.parseSkip _proxy _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do !__val__dividend <- ST.readSTRef + __field__dividend + !__val__divisor <- ST.readSTRef __field__divisor + Prelude.pure + (Thrift.Some (QuotRem __val__dividend __val__divisor)) + _idMap = HashMap.fromList [("dividend", 1), ("divisor", 2)] + _parse 0) +reqParser' _proxy "put" + = ST.runSTT + (do Prelude.return () + __field__val <- ST.newSTRef Default.def + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 1 | _type == Thrift.getI64Type _proxy + -> + do !_val <- Trans.lift + (Prelude.fromIntegral + <$> + Thrift.parseI64 + _proxy) + ST.writeSTRef __field__val + _val + _ -> Trans.lift + (Thrift.parseSkip _proxy _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do !__val__val <- ST.readSTRef __field__val + Prelude.pure (Thrift.Some (Put __val__val)) + _idMap = HashMap.fromList [("val", 1)] + _parse 0) +reqParser' _proxy "putMany" + = ST.runSTT + (do Prelude.return () + __field__val <- ST.newSTRef Default.def + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 1 | _type == + Thrift.getListType _proxy + -> + do !_val <- Trans.lift + (Prelude.snd <$> + Thrift.parseList + _proxy + (Prelude.fromIntegral + <$> + Thrift.parseI64 + _proxy)) + ST.writeSTRef __field__val + _val + _ -> Trans.lift + (Thrift.parseSkip _proxy _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do !__val__val <- ST.readSTRef __field__val + Prelude.pure (Thrift.Some (PutMany __val__val)) + _idMap = HashMap.fromList [("val", 1)] + _parse 0) +reqParser' _proxy "get" + = ST.runSTT + (do Prelude.return () + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + _ -> Trans.lift + (Thrift.parseSkip _proxy _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do Prelude.pure (Thrift.Some Get) + _idMap = HashMap.fromList [] + _parse 0) +reqParser' _proxy "unimplemented" + = ST.runSTT + (do Prelude.return () + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + _ -> Trans.lift + (Thrift.parseSkip _proxy _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do Prelude.pure (Thrift.Some Unimplemented) + _idMap = HashMap.fromList [] + _parse 0) +reqParser' _proxy funName + = do Thrift.Some x <- Adder.reqParser' _proxy funName + Prelude.return (Thrift.Some (SuperAdder x)) + +respWriter' :: + Thrift.Protocol p => + Proxy.Proxy p -> + Int.Int32 -> + CalculatorCommand a -> + Prelude.Either Exception.SomeException a -> + (Builder.Builder, + Prelude.Maybe (Exception.SomeException, Thrift.Blame)) +respWriter' _proxy _seqNum Divide{} _r + = (Thrift.genMsgBegin _proxy "divide" _msgType _seqNum <> _msgBody + <> Thrift.genMsgEnd _proxy, + _msgException) + where + (_msgType, _msgBody, _msgException) + = case _r of + Prelude.Left _ex | Prelude.Just + _e@Thrift.ApplicationException{} <- Exception.fromException _ex + -> + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (_ex, Thrift.ServerError)) + | Prelude.Just _e@Types.DivideByZero{} <- Exception.fromException + _ex + -> + (2, + Thrift.genStruct _proxy + [Thrift.genField _proxy "divisionError" + (Thrift.getStructType _proxy) + 1 + 0 + (Thrift.buildStruct _proxy _e)], + Prelude.Just (_ex, Thrift.ClientError)) + | Prelude.otherwise -> + let _e + = Thrift.ApplicationException (Text.pack (Prelude.show _ex)) + Thrift.ApplicationExceptionType_InternalError + in + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (Exception.toException _e, Thrift.ServerError)) + Prelude.Right _result -> (2, + Thrift.genStruct _proxy + [Thrift.genField _proxy "" (Thrift.getDoubleType _proxy) 0 0 + (Thrift.genDouble _proxy _result)], + Prelude.Nothing) +respWriter' _proxy _seqNum QuotRem{} _r + = (Thrift.genMsgBegin _proxy "quotRem" _msgType _seqNum <> _msgBody + <> Thrift.genMsgEnd _proxy, + _msgException) + where + (_msgType, _msgBody, _msgException) + = case _r of + Prelude.Left _ex | Prelude.Just + _e@Thrift.ApplicationException{} <- Exception.fromException _ex + -> + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (_ex, Thrift.ServerError)) + | Prelude.otherwise -> + let _e + = Thrift.ApplicationException (Text.pack (Prelude.show _ex)) + Thrift.ApplicationExceptionType_InternalError + in + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (Exception.toException _e, Thrift.ServerError)) + Prelude.Right _result -> (2, + Thrift.genStruct _proxy + [Thrift.genField _proxy "" (Thrift.getStructType _proxy) 0 0 + (Thrift.buildStruct _proxy _result)], + Prelude.Nothing) +respWriter' _proxy _seqNum Put{} _r + = (Thrift.genMsgBegin _proxy "put" _msgType _seqNum <> _msgBody <> + Thrift.genMsgEnd _proxy, + _msgException) + where + (_msgType, _msgBody, _msgException) + = case _r of + Prelude.Left _ex | Prelude.Just + _e@Thrift.ApplicationException{} <- Exception.fromException _ex + -> + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (_ex, Thrift.ServerError)) + | Prelude.otherwise -> + let _e + = Thrift.ApplicationException (Text.pack (Prelude.show _ex)) + Thrift.ApplicationExceptionType_InternalError + in + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (Exception.toException _e, Thrift.ServerError)) + Prelude.Right _result -> (2, Thrift.genStruct _proxy [], + Prelude.Nothing) +respWriter' _proxy _seqNum PutMany{} _r + = (Thrift.genMsgBegin _proxy "putMany" _msgType _seqNum <> _msgBody + <> Thrift.genMsgEnd _proxy, + _msgException) + where + (_msgType, _msgBody, _msgException) + = case _r of + Prelude.Left _ex | Prelude.Just + _e@Thrift.ApplicationException{} <- Exception.fromException _ex + -> + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (_ex, Thrift.ServerError)) + | Prelude.otherwise -> + let _e + = Thrift.ApplicationException (Text.pack (Prelude.show _ex)) + Thrift.ApplicationExceptionType_InternalError + in + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (Exception.toException _e, Thrift.ServerError)) + Prelude.Right _result -> (2, Thrift.genStruct _proxy [], + Prelude.Nothing) +respWriter' _proxy _seqNum Get{} _r + = (Thrift.genMsgBegin _proxy "get" _msgType _seqNum <> _msgBody <> + Thrift.genMsgEnd _proxy, + _msgException) + where + (_msgType, _msgBody, _msgException) + = case _r of + Prelude.Left _ex | Prelude.Just + _e@Thrift.ApplicationException{} <- Exception.fromException _ex + -> + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (_ex, Thrift.ServerError)) + | Prelude.otherwise -> + let _e + = Thrift.ApplicationException (Text.pack (Prelude.show _ex)) + Thrift.ApplicationExceptionType_InternalError + in + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (Exception.toException _e, Thrift.ServerError)) + Prelude.Right _result -> (2, + Thrift.genStruct _proxy + [Thrift.genField _proxy "" (Thrift.getI64Type _proxy) 0 0 + ((Thrift.genI64 _proxy . Prelude.fromIntegral) _result)], + Prelude.Nothing) +respWriter' _proxy _seqNum Unimplemented{} _r + = (Thrift.genMsgBegin _proxy "unimplemented" _msgType _seqNum <> + _msgBody + <> Thrift.genMsgEnd _proxy, + _msgException) + where + (_msgType, _msgBody, _msgException) + = case _r of + Prelude.Left _ex | Prelude.Just + _e@Thrift.ApplicationException{} <- Exception.fromException _ex + -> + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (_ex, Thrift.ServerError)) + | Prelude.otherwise -> + let _e + = Thrift.ApplicationException (Text.pack (Prelude.show _ex)) + Thrift.ApplicationExceptionType_InternalError + in + (3, Thrift.buildStruct _proxy _e, + Prelude.Just (Exception.toException _e, Thrift.ServerError)) + Prelude.Right _result -> (2, Thrift.genStruct _proxy [], + Prelude.Nothing) +respWriter' _proxy _seqNum (SuperAdder _x) _r + = Adder.respWriter' _proxy _seqNum _x _r + +methodsInfo' :: Map.Map Text.Text Thrift.MethodInfo +methodsInfo' + = Map.union + (Map.fromList + [("divide", Thrift.MethodInfo Thrift.NormalPriority Prelude.False), + ("quotRem", Thrift.MethodInfo Thrift.NormalPriority Prelude.False), + ("put", Thrift.MethodInfo Thrift.NormalPriority Prelude.True), + ("putMany", Thrift.MethodInfo Thrift.NormalPriority Prelude.True), + ("get", Thrift.MethodInfo Thrift.NormalPriority Prelude.False), + ("unimplemented", + Thrift.MethodInfo Thrift.NormalPriority Prelude.False)]) + Adder.methodsInfo' diff --git a/test/gen-hs2/Math/Types.hs b/test/gen-hs2/Math/Types.hs new file mode 100644 --- /dev/null +++ b/test/gen-hs2/Math/Types.hs @@ -0,0 +1,148 @@ +----------------------------------------------------------------- +-- Autogenerated by Thrift +-- +-- DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING +-- @generated +----------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports#-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns#-} +{-# OPTIONS_GHC -fno-warn-incomplete-record-updates#-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Math.Types + (DivideByZero(DivideByZero), + QuotRemResponse(QuotRemResponse, quotRemResponse_quot, + quotRemResponse_rem)) + where +import qualified Control.DeepSeq as DeepSeq +import qualified Control.Exception as Exception +import qualified Control.Monad as Monad +import qualified Control.Monad.ST.Trans as ST +import qualified Control.Monad.Trans.Class as Trans +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import qualified Data.Default as Default +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Hashable as Hashable +import qualified Data.List as List +import qualified Data.Ord as Ord +import qualified Prelude as Prelude +import qualified Thrift.Binary.Parser as Parser +import qualified Thrift.CodegenTypesOnly as Thrift +import Control.Applicative ((<|>), (*>), (<*)) +import Data.Aeson ((.:), (.:?), (.=), (.!=)) +import Data.Monoid ((<>)) +import Prelude ((.), (<$>), (<*>), (>>=), (==), (/=), (<), (++)) + +data DivideByZero = DivideByZero{} + deriving (Prelude.Eq, Prelude.Show, Prelude.Ord) + +instance Aeson.ToJSON DivideByZero where + toJSON DivideByZero = Aeson.object Prelude.mempty + +instance Thrift.ThriftStruct DivideByZero where + buildStruct _proxy DivideByZero = Thrift.genStruct _proxy [] + parseStruct _proxy + = ST.runSTT + (do Prelude.return () + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + _ -> Trans.lift + (Thrift.parseSkip _proxy + _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do Prelude.pure (DivideByZero) + _idMap = HashMap.fromList [] + _parse 0) + +instance DeepSeq.NFData DivideByZero where + rnf DivideByZero = () + +instance Default.Default DivideByZero where + def = DivideByZero + +instance Hashable.Hashable DivideByZero where + hashWithSalt __salt DivideByZero = __salt + +instance Exception.Exception DivideByZero + +data QuotRemResponse = QuotRemResponse{quotRemResponse_quot :: + Prelude.Int, + quotRemResponse_rem :: Prelude.Int} + deriving (Prelude.Eq, Prelude.Show, Prelude.Ord) + +instance Aeson.ToJSON QuotRemResponse where + toJSON (QuotRemResponse __field__quot __field__rem) + = Aeson.object + ("quot" .= __field__quot : "rem" .= __field__rem : Prelude.mempty) + +instance Thrift.ThriftStruct QuotRemResponse where + buildStruct _proxy (QuotRemResponse __field__quot __field__rem) + = Thrift.genStruct _proxy + (Thrift.genField _proxy "quot" (Thrift.getI64Type _proxy) 1 0 + ((Thrift.genI64 _proxy . Prelude.fromIntegral) __field__quot) + : + Thrift.genField _proxy "rem" (Thrift.getI64Type _proxy) 2 1 + ((Thrift.genI64 _proxy . Prelude.fromIntegral) __field__rem) + : []) + parseStruct _proxy + = ST.runSTT + (do Prelude.return () + __field__quot <- ST.newSTRef Default.def + __field__rem <- ST.newSTRef Default.def + let + _parse _lastId + = do _fieldBegin <- Trans.lift + (Thrift.parseFieldBegin _proxy _lastId _idMap) + case _fieldBegin of + Thrift.FieldBegin _type _id _bool -> do case _id of + 1 | _type == + Thrift.getI64Type _proxy + -> + do !_val <- Trans.lift + (Prelude.fromIntegral + <$> + Thrift.parseI64 + _proxy) + ST.writeSTRef __field__quot + _val + 2 | _type == + Thrift.getI64Type _proxy + -> + do !_val <- Trans.lift + (Prelude.fromIntegral + <$> + Thrift.parseI64 + _proxy) + ST.writeSTRef __field__rem + _val + _ -> Trans.lift + (Thrift.parseSkip _proxy + _type + (Prelude.Just _bool)) + _parse _id + Thrift.FieldEnd -> do !__val__quot <- ST.readSTRef __field__quot + !__val__rem <- ST.readSTRef __field__rem + Prelude.pure (QuotRemResponse __val__quot __val__rem) + _idMap = HashMap.fromList [("quot", 1), ("rem", 2)] + _parse 0) + +instance DeepSeq.NFData QuotRemResponse where + rnf (QuotRemResponse __field__quot __field__rem) + = DeepSeq.rnf __field__quot `Prelude.seq` + DeepSeq.rnf __field__rem `Prelude.seq` () + +instance Default.Default QuotRemResponse where + def = QuotRemResponse Default.def Default.def + +instance Hashable.Hashable QuotRemResponse where + hashWithSalt __salt (QuotRemResponse _quot _rem) + = Hashable.hashWithSalt (Hashable.hashWithSalt __salt _quot) _rem diff --git a/thrift-http.cabal b/thrift-http.cabal new file mode 100644 --- /dev/null +++ b/thrift-http.cabal @@ -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 + + +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