diff options
author | Jens Geyer <jensg@apache.org> | 2021-03-20 18:07:17 +0100 |
---|---|---|
committer | Jens Geyer <jensg@apache.org> | 2021-03-22 09:42:38 +0100 |
commit | 66d897667c451ef6560d89b979b7001c57a3eda6 (patch) | |
tree | 4420429109c582375fc68aa125a2b6f6b8019dd3 | |
parent | cd2fae091b9bafd0977ef290f722532c36a64d2e (diff) | |
download | thrift-66d897667c451ef6560d89b979b7001c57a3eda6.tar.gz |
THRIFT-5347 Remove deprecated Haskell bindings
Client: hs
Patch: Jens Geyer
This closes #2352
80 files changed, 2 insertions, 7272 deletions
diff --git a/.travis.yml b/.travis.yml index f3dc7e4a7..409eee777 100644 --- a/.travis.yml +++ b/.travis.yml @@ -44,7 +44,7 @@ env: - BUILD_ARG="" - BUILD_ENV="-e CC=gcc -e CXX=g++ -e THRIFT_CROSSTEST_CONCURRENCY=4" - DISTRO=ubuntu-bionic - - BUILD_LIBS="CPP C_GLIB HASKELL JAVA PYTHON TESTING TUTORIALS" # only meaningful for CMake builds + - BUILD_LIBS="CPP C_GLIB JAVA PYTHON TESTING TUTORIALS" # only meaningful for CMake builds - TRAVIS_BUILD_STAGE=test # DOCKER_REPO (this works for all builds as a source for docker images - you can override for fork builds in your Travis settings) - DOCKER_REPO="thrift/thrift-build" diff --git a/CMakeLists.txt b/CMakeLists.txt index d151fc012..3b341d057 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -124,13 +124,6 @@ if(BUILD_PYTHON) endif() endif() -if(BUILD_HASKELL) - add_subdirectory(${CMAKE_CURRENT_SOURCE_DIR}/lib/hs) - if(BUILD_TESTING) - add_subdirectory(${CMAKE_CURRENT_SOURCE_DIR}/test/hs) - endif() -endif() - # Create the uninstall target add_custom_target(uninstall "${CMAKE_COMMAND}" -P "${PROJECT_SOURCE_DIR}/build/cmake/uninstall.cmake") diff --git a/LANGUAGES.md b/LANGUAGES.md index 4d887210d..34cced048 100644 --- a/LANGUAGES.md +++ b/LANGUAGES.md @@ -159,17 +159,6 @@ Thrift's core protocol is TBinary, supported by all languages except for JavaScr <td align=left><a href="https://issues.apache.org/jira/issues/?jql=project%20%3D%20THRIFT%20AND%20component%20in%20(%22Go%20-%20Compiler%22%2C%20%22Go%20-%20Library%22)%20and%20status%20not%20in%20(fixed%2C%20resolved%2C%20closed)">Go</a></td> </tr> <tr align=center> -<td align=left><a href="https://github.com/apache/thrift/blob/master/lib/hs/README.md">Haskell</a></td> -<!-- Since -----------------><td>0.5.0</td> -<!-- Build Systems ---------><td><img src="doc/images/cgrn.png" alt="Yes"/></td><td><img src="doc/images/cgrn.png" alt="Yes"/></td> -<!-- Language Levels -------><td>7.10.3</td><td>8.0.2</td> -<!-- Low-Level Transports --><td><img src="doc/images/cred.png" alt=""/></td><td><img src="doc/images/cgrn.png" alt="Yes"/></td><td><img src="doc/images/cgrn.png" alt="Yes"/></td><td><img src="doc/images/cred.png" alt=""/></td><td><img src="doc/images/cgrn.png" alt="Yes"/></td><td><img src="doc/images/cgrn.png" alt="Yes"/></td> -<!-- Transport Wrappers ----><td><img src="doc/images/cgrn.png" alt="Yes"/></td><td><img src="doc/images/cred.png" alt=""/></td><td><img src="doc/images/cgrn.png" alt="Yes"/></td><td><img src="doc/images/cred.png" alt=""/></td> -<!-- Protocols -------------><td><img src="doc/images/cgrn.png" alt="Yes"/></td><td><img src="doc/images/cgrn.png" alt="Yes"/></td><td><img src="doc/images/cgrn.png" alt="Yes"/></td><td><img src="doc/images/cred.png" alt=""/></td> -<!-- Servers ---------------><td><img src="doc/images/cred.png" alt=""/></td><td><img src="doc/images/cred.png" alt=""/></td><td><img src="doc/images/cgrn.png" alt="Yes"/></td><td><img src="doc/images/cgrn.png" alt="Yes"/></td><td><img src="doc/images/cred.png" alt=""/></td> -<td align=left><a href="https://issues.apache.org/jira/issues/?jql=project%20%3D%20THRIFT%20AND%20component%20in%20(%22Haskell%20-%20Compiler%22%2C%20%22Haskell%20-%20Library%22)%20and%20status%20not%20in%20(fixed%2C%20resolved%2C%20closed)">Haskell</a></td> -</tr> -<tr align=center> <td align=left><a href="https://github.com/apache/thrift/blob/master/lib/haxe/README.md">Haxe</a></td> <!-- Since -----------------><td>0.9.3</td> <!-- Build Systems ---------><td><img src="doc/images/cgrn.png" alt="Yes"/></td><td><img src="doc/images/cred.png" alt=""/></td> diff --git a/Makefile.am b/Makefile.am index 3db9ffa57..a1322098b 100755 --- a/Makefile.am +++ b/Makefile.am @@ -78,7 +78,7 @@ empty := space := $(empty) $(empty) comma := , -CROSS_LANGS = @MAYBE_CPP@ @MAYBE_C_GLIB@ @MAYBE_CL@ @MAYBE_D@ @MAYBE_JAVA@ @MAYBE_PYTHON@ @MAYBE_PY3@ @MAYBE_RUBY@ @MAYBE_HASKELL@ @MAYBE_PERL@ @MAYBE_PHP@ @MAYBE_GO@ @MAYBE_NODEJS@ @MAYBE_DART@ @MAYBE_ERLANG@ @MAYBE_LUA@ @MAYBE_RS@ @MAYBE_NETSTD@ @MAYBE_NODETS@ +CROSS_LANGS = @MAYBE_CPP@ @MAYBE_C_GLIB@ @MAYBE_CL@ @MAYBE_D@ @MAYBE_JAVA@ @MAYBE_PYTHON@ @MAYBE_PY3@ @MAYBE_RUBY@ @MAYBE_PERL@ @MAYBE_PHP@ @MAYBE_GO@ @MAYBE_NODEJS@ @MAYBE_DART@ @MAYBE_ERLANG@ @MAYBE_LUA@ @MAYBE_RS@ @MAYBE_NETSTD@ @MAYBE_NODETS@ CROSS_LANGS_COMMA_SEPARATED = $(subst $(space),$(comma),$(CROSS_LANGS)) if WITH_PY3 diff --git a/build/appveyor/MSVC-appveyor-install.bat b/build/appveyor/MSVC-appveyor-install.bat index 09b7cc494..a4c49fe14 100644 --- a/build/appveyor/MSVC-appveyor-install.bat +++ b/build/appveyor/MSVC-appveyor-install.bat @@ -56,9 +56,6 @@ pip.exe ^ tornado ^ twisted || EXIT /B -cinst -y cabal --version 2.4.1.0 || EXIT /B -cinst -y ghc --version 8.6.5 || EXIT /B - :: Adobe Flex SDK 4.6 for ActionScript MKDIR "C:\Adobe\Flex\SDK\4.6" || EXIT /B appveyor DownloadFile http://download.macromedia.com/pub/flex/sdk/flex_sdk_4.6.zip -FileName C:\Adobe\Flex\SDK\4.6\SDK.zip || EXIT /B diff --git a/build/cmake/DefineOptions.cmake b/build/cmake/DefineOptions.cmake index e16e5649c..1fa7a568c 100644 --- a/build/cmake/DefineOptions.cmake +++ b/build/cmake/DefineOptions.cmake @@ -122,13 +122,6 @@ find_package(PythonLibs QUIET) # for Python.h CMAKE_DEPENDENT_OPTION(BUILD_PYTHON "Build Python library" ON "BUILD_LIBRARIES;WITH_PYTHON;PYTHONINTERP_FOUND;PYTHONLIBS_FOUND" OFF) -# Haskell -option(WITH_HASKELL "Build Haskell Thrift library" ON) -find_package(GHC QUIET) -find_package(Cabal QUIET) -CMAKE_DEPENDENT_OPTION(BUILD_HASKELL "Build GHC library" ON - "BUILD_LIBRARIES;WITH_HASKELL;GHC_FOUND;CABAL_FOUND" OFF) - # Common library options # https://cmake.org/cmake/help/latest/variable/BUILD_SHARED_LIBS.html # Default on Windows is static, shared mode library support needs work... @@ -215,10 +208,6 @@ message(STATUS " Build Python library: ${BUILD_PYTHON}") MESSAGE_DEP(WITH_PYTHON "Disabled by WITH_PYTHON=OFF") MESSAGE_DEP(PYTHONLIBS_FOUND "Python libraries missing") message(STATUS) -message(STATUS " Build Haskell library: ${BUILD_HASKELL}") -MESSAGE_DEP(WITH_HASKELL "Disabled by WITH_HASKELL=OFF") -MESSAGE_DEP(GHC_FOUND "GHC missing") -MESSAGE_DEP(CABAL_FOUND "Cabal missing") message(STATUS) message(STATUS "----------------------------------------------------------") endmacro(PRINT_CONFIG_SUMMARY) diff --git a/build/cmake/FindCabal.cmake b/build/cmake/FindCabal.cmake deleted file mode 100644 index fed337bd4..000000000 --- a/build/cmake/FindCabal.cmake +++ /dev/null @@ -1,30 +0,0 @@ -# -# Licensed to the Apache Software Foundation (ASF) under one -# or more contributor license agreements. See the NOTICE file -# distributed with this work for additional information -# regarding copyright ownership. The ASF licenses this file -# to you under the Apache License, Version 2.0 (the -# "License"); you may not use this file except in compliance -# with the License. You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, -# software distributed under the License is distributed on an -# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -# KIND, either express or implied. See the License for the -# specific language governing permissions and limitations -# under the License. -# - - -# Cabal_FOUND - system has Cabal -# Cabal - the Cabal executable -# -# It will search the environment variable CABAL_HOME if it is set - -include(FindPackageHandleStandardArgs) - -find_program(CABAL NAMES cabal PATHS $ENV{HOME}/.cabal/bin $ENV{CABAL_HOME}/bin) -find_package_handle_standard_args(CABAL DEFAULT_MSG CABAL) -mark_as_advanced(CABAL) diff --git a/build/cmake/FindGHC.cmake b/build/cmake/FindGHC.cmake deleted file mode 100644 index 48738472c..000000000 --- a/build/cmake/FindGHC.cmake +++ /dev/null @@ -1,36 +0,0 @@ -# -# Licensed to the Apache Software Foundation (ASF) under one -# or more contributor license agreements. See the NOTICE file -# distributed with this work for additional information -# regarding copyright ownership. The ASF licenses this file -# to you under the Apache License, Version 2.0 (the -# "License"); you may not use this file except in compliance -# with the License. You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, -# software distributed under the License is distributed on an -# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -# KIND, either express or implied. See the License for the -# specific language governing permissions and limitations -# under the License. -# - - -# GHC_FOUND - system has GHC -# GHC - the GHC executable -# RUN_HASKELL_FOUND - system has runhaskell -# RUN_HASKELL - the runhaskell executable -# -# It will search the environment variable GHC_HOME if it is set - -include(FindPackageHandleStandardArgs) - -find_program(GHC NAMES ghc PATHS $ENV{GHC_HOME}/bin) -find_package_handle_standard_args(GHC DEFAULT_MSG GHC) -mark_as_advanced(GHC) - -find_program(RUN_HASKELL NAMES runhaskell PATHS $ENV{GHC_HOME}/bin) -find_package_handle_standard_args(RUN_HASKELL DEFAULT_MSG RUN_HASKELL) -mark_as_advanced(RUN_HASKELL) diff --git a/build/docker/README.md b/build/docker/README.md index ff0fb0bab..4ee57d19b 100644 --- a/build/docker/README.md +++ b/build/docker/README.md @@ -179,7 +179,6 @@ Last updated: October 1, 2017 | delphi | | | Not in CI | | erlang | 18.3 | 22.0 | | | go | 1.14.14 | 1.15.7 | | -| haskell | 7.10.3 | 8.0.2 | | | haxe | 3.2.1 | 3.4.4 | THRIFT-4352: avoid 3.4.2 | | java | 1.8.0_191 | 11.0.3 | | | js | Node.js 6.17.1, V8 5.1.281.111, npm 3.10.10 | Node.js 10.18.0, V8 6.8.275.32, npm 6.13.4 | | diff --git a/build/docker/msvc2017/Dockerfile b/build/docker/msvc2017/Dockerfile index a2b3cd7e2..d59c19568 100644 --- a/build/docker/msvc2017/Dockerfile +++ b/build/docker/msvc2017/Dockerfile @@ -83,9 +83,6 @@ RUN C:\TEMP\openssl.exe /silent && ` # Install java RUN choco install jdk8 -y -# Install haskell -RUN choco install ghc -y - # Install python3 RUN choco install python3 -y diff --git a/build/docker/old/centos-7.3/Dockerfile b/build/docker/old/centos-7.3/Dockerfile index 096bbaa45..ba4c54926 100644 --- a/build/docker/old/centos-7.3/Dockerfile +++ b/build/docker/old/centos-7.3/Dockerfile @@ -95,9 +95,6 @@ RUN yum install -y glib2-devel RUN curl -sSL https://storage.googleapis.com/golang/go1.9.linux-amd64.tar.gz | tar -C /usr/local/ -xz ENV PATH /usr/local/go/bin:$PATH -# Haskell Dependencies -RUN yum -y install haskell-platform - # Haxe Dependencies # Not in debian/stretch diff --git a/build/docker/old/debian-jessie/Dockerfile b/build/docker/old/debian-jessie/Dockerfile index a49b2078c..15e02e9c1 100644 --- a/build/docker/old/debian-jessie/Dockerfile +++ b/build/docker/old/debian-jessie/Dockerfile @@ -109,9 +109,6 @@ RUN apt-get update && apt-get install -y --no-install-recommends \ rebar RUN apt-get update && apt-get install -y --no-install-recommends \ -`# Haskell dependencies` \ - ghc \ - cabal-install \ `# Haxe dependencies` \ neko \ neko-dev \ diff --git a/build/docker/old/debian-stretch/Dockerfile b/build/docker/old/debian-stretch/Dockerfile index 06a34cf19..ebb5e24eb 100644 --- a/build/docker/old/debian-stretch/Dockerfile +++ b/build/docker/old/debian-stretch/Dockerfile @@ -121,11 +121,6 @@ RUN apt-get install -y --no-install-recommends \ golang-go RUN apt-get install -y --no-install-recommends \ -`# Haskell dependencies` \ - ghc \ - cabal-install - -RUN apt-get install -y --no-install-recommends \ `# Haxe dependencies` \ haxe \ neko \ diff --git a/build/docker/old/ubuntu-artful/Dockerfile b/build/docker/old/ubuntu-artful/Dockerfile index 854f87c4f..cb723a20e 100644 --- a/build/docker/old/ubuntu-artful/Dockerfile +++ b/build/docker/old/ubuntu-artful/Dockerfile @@ -145,11 +145,6 @@ RUN curl -fsSL "$GOLANG_DOWNLOAD_URL" -o golang.tar.gz && \ rm golang.tar.gz RUN apt-get install -y --no-install-recommends \ -`# Haskell dependencies` \ - ghc \ - cabal-install - -RUN apt-get install -y --no-install-recommends \ `# Haxe dependencies` \ haxe \ neko \ diff --git a/build/docker/old/ubuntu-trusty/Dockerfile b/build/docker/old/ubuntu-trusty/Dockerfile index 96c154019..89f683e4b 100644 --- a/build/docker/old/ubuntu-trusty/Dockerfile +++ b/build/docker/old/ubuntu-trusty/Dockerfile @@ -119,11 +119,6 @@ RUN curl -fsSL "$GOLANG_DOWNLOAD_URL" -o golang.tar.gz && \ ln -s /usr/local/go/bin/go /usr/local/bin && \ rm golang.tar.gz -RUN apt-get install -y --no-install-recommends \ -`# Haskell dependencies` \ - ghc \ - cabal-install - # disabled because it cores while installing # RUN apt-get install -y --no-install-recommends \ # `# Haxe dependencies` \ diff --git a/build/docker/ubuntu-bionic/Dockerfile b/build/docker/ubuntu-bionic/Dockerfile index 61364bc36..699ae503a 100644 --- a/build/docker/ubuntu-bionic/Dockerfile +++ b/build/docker/ubuntu-bionic/Dockerfile @@ -150,11 +150,6 @@ RUN curl -fsSL "$GOLANG_DOWNLOAD_URL" -o golang.tar.gz && \ rm golang.tar.gz RUN apt-get install -y --no-install-recommends \ -`# Haskell dependencies` \ - ghc \ - cabal-install - -RUN apt-get install -y --no-install-recommends \ `# Haxe dependencies` \ haxe \ neko \ diff --git a/build/docker/ubuntu-disco/Dockerfile b/build/docker/ubuntu-disco/Dockerfile index 1811dc989..dd2df42d5 100644 --- a/build/docker/ubuntu-disco/Dockerfile +++ b/build/docker/ubuntu-disco/Dockerfile @@ -150,11 +150,6 @@ RUN curl -fsSL "$GOLANG_DOWNLOAD_URL" -o golang.tar.gz && \ rm golang.tar.gz RUN apt-get install -y --no-install-recommends \ -`# Haskell dependencies` \ - ghc \ - cabal-install - -RUN apt-get install -y --no-install-recommends \ `# Haxe dependencies` \ haxe \ neko \ diff --git a/build/docker/ubuntu-xenial/Dockerfile b/build/docker/ubuntu-xenial/Dockerfile index e3aff74e4..bc66786fa 100644 --- a/build/docker/ubuntu-xenial/Dockerfile +++ b/build/docker/ubuntu-xenial/Dockerfile @@ -146,18 +146,6 @@ RUN curl -fsSL "$GOLANG_DOWNLOAD_URL" -o golang.tar.gz && \ ln -s /usr/local/go/bin/go /usr/local/bin && \ rm golang.tar.gz -# cabal 1.22 in xenial is too old so we grab a pre-built 1.24 binary -RUN apt-get install -y --no-install-recommends \ -`# Haskell dependencies` \ - ghc && \ - cd /tmp && \ - wget -q https://www.haskell.org/cabal/release/cabal-install-1.24.0.2/cabal-install-1.24.0.2-x86_64-unknown-linux.tar.gz && \ - tar xzf cabal-install-1.24.0.2-x86_64-unknown-linux.tar.gz && \ - find dist-newstyle/ -type f -name cabal -exec mv {} /usr/bin \; && \ - rm -rf /tmp/cabal* && \ - cabal --version && \ - cabal update - RUN apt-get install -y --no-install-recommends \ `# Haxe dependencies` \ haxe \ diff --git a/build/veralign.sh b/build/veralign.sh index 7080237a2..3823e2d52 100755 --- a/build/veralign.sh +++ b/build/veralign.sh @@ -65,7 +65,6 @@ FILES[lib/dart/pubspec.yaml]=pubspecReplace FILES[lib/delphi/src/Thrift.pas]=simpleReplace FILES[lib/erl/src/thrift.app.src]=simpleReplace FILES[lib/haxe/haxelib.json]=simpleReplace -FILES[lib/hs/thrift.cabal]=simpleReplace FILES[lib/java/gradle.properties]=simpleReplace FILES[lib/js/package-lock.json]=jsonReplace FILES[lib/js/package.json]=jsonReplace @@ -99,7 +98,6 @@ FILES[tutorial/dart/console_client/pubspec.yaml]=pubspecReplace FILES[tutorial/dart/server/pubspec.yaml]=pubspecReplace FILES[tutorial/delphi/DelphiClient/DelphiClient.dproj]=simpleReplace FILES[tutorial/delphi/DelphiServer/DelphiServer.dproj]=simpleReplace -FILES[tutorial/hs/ThriftTutorial.cabal]=simpleReplace FILES[tutorial/netstd/Client/Client.csproj]=simpleReplace FILES[tutorial/netstd/Interfaces/Interfaces.csproj]=simpleReplace FILES[tutorial/netstd/Server/Server.csproj]=simpleReplace diff --git a/compiler/cpp/CMakeLists.txt b/compiler/cpp/CMakeLists.txt index 34604d0f4..df3463782 100644 --- a/compiler/cpp/CMakeLists.txt +++ b/compiler/cpp/CMakeLists.txt @@ -82,7 +82,6 @@ THRIFT_ADD_COMPILER(erl "Enable compiler for Erlang" ON) THRIFT_ADD_COMPILER(go "Enable compiler for Go" ON) THRIFT_ADD_COMPILER(gv "Enable compiler for GraphViz" ON) THRIFT_ADD_COMPILER(haxe "Enable compiler for Haxe" ON) -THRIFT_ADD_COMPILER(hs "Enable compiler for Haskell" ON) THRIFT_ADD_COMPILER(html "Enable compiler for HTML Documentation" ON) THRIFT_ADD_COMPILER(markdown "Enable compiler for Markdown Documentation" ON) THRIFT_ADD_COMPILER(java "Enable compiler for Java" ON) diff --git a/compiler/cpp/Makefile.am b/compiler/cpp/Makefile.am index 2b83d94be..74def54c9 100644 --- a/compiler/cpp/Makefile.am +++ b/compiler/cpp/Makefile.am @@ -79,7 +79,6 @@ thrift_SOURCES += src/thrift/generate/t_c_glib_generator.cc \ src/thrift/generate/t_go_generator.cc \ src/thrift/generate/t_gv_generator.cc \ src/thrift/generate/t_haxe_generator.cc \ - src/thrift/generate/t_hs_generator.cc \ src/thrift/generate/t_html_generator.cc \ src/thrift/generate/t_markdown_generator.cc \ src/thrift/generate/t_java_generator.cc \ diff --git a/compiler/cpp/compiler.vcxproj b/compiler/cpp/compiler.vcxproj index 31bc5954b..423c55ecf 100644 --- a/compiler/cpp/compiler.vcxproj +++ b/compiler/cpp/compiler.vcxproj @@ -64,7 +64,6 @@ <ClCompile Include="src\thrift\generate\t_go_generator.cc" /> <ClCompile Include="src\thrift\generate\t_gv_generator.cc" /> <ClCompile Include="src\thrift\generate\t_haxe_generator.cc" /> - <ClCompile Include="src\thrift\generate\t_hs_generator.cc" /> <ClCompile Include="src\thrift\generate\t_html_generator.cc" /> <ClCompile Include="src\thrift\generate\t_markdown_generator.cc" /> <ClCompile Include="src\thrift\generate\t_java_generator.cc" /> diff --git a/compiler/cpp/compiler.vcxproj.filters b/compiler/cpp/compiler.vcxproj.filters index b5fdce7fb..546d0fdc6 100644 --- a/compiler/cpp/compiler.vcxproj.filters +++ b/compiler/cpp/compiler.vcxproj.filters @@ -125,9 +125,6 @@ <ClCompile Include="src\generate\t_haxe_generator.cc"> <Filter>generate</Filter> </ClCompile> - <ClCompile Include="src\generate\t_hs_generator.cc"> - <Filter>generate</Filter> - </ClCompile> <ClCompile Include="src\generate\t_html_generator.cc"> <Filter>generate</Filter> </ClCompile> diff --git a/compiler/cpp/src/thrift/generate/t_generator.cc b/compiler/cpp/src/thrift/generate/t_generator.cc index 1c540d49d..f26690b9a 100644 --- a/compiler/cpp/src/thrift/generate/t_generator.cc +++ b/compiler/cpp/src/thrift/generate/t_generator.cc @@ -237,9 +237,6 @@ t_generator* t_generator_registry::get_generator(t_program* program, if ((language == "csharp") || (language == "netcore")) { failure("The '%s' target is no longer available. Use 'netstd' instead.", language.c_str()); } - else if (language == "hs") { - pwarning(1, "The '%s' target is deprecated and will be removed in future Thrift versions.", language.c_str()); - } if (iter == the_map.end()) { return nullptr; diff --git a/compiler/cpp/src/thrift/generate/t_hs_generator.cc b/compiler/cpp/src/thrift/generate/t_hs_generator.cc deleted file mode 100644 index d314b8f2c..000000000 --- a/compiler/cpp/src/thrift/generate/t_hs_generator.cc +++ /dev/null @@ -1,1717 +0,0 @@ -/* - * Licensed to the Apache Software Foundation (ASF) under one - * or more contributor license agreements. See the NOTICE file - * distributed with this work for additional information - * regarding copyright ownership. The ASF licenses this file - * to you under the Apache License, Version 2.0 (the - * "License"); you may not use this file except in compliance - * with the License. You may obtain a copy of the License at - * - * http://www.apache.org/licenses/LICENSE-2.0 - * - * Unless required by applicable law or agreed to in writing, - * software distributed under the License is distributed on an - * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY - * KIND, either express or implied. See the License for the - * specific language governing permissions and limitations - * under the License. - */ - -#include <string> -#include <fstream> -#include <iostream> -#include <vector> - -#include <stdlib.h> -#include <sys/stat.h> -#include <sys/types.h> -#include <sstream> - -#include "thrift/platform.h" -#include "thrift/version.h" - -#include "thrift/generate/t_oop_generator.h" - -using std::map; -using std::ostream; -using std::ostringstream; -using std::string; -using std::stringstream; -using std::vector; - -static const string endl = "\n"; // avoid ostream << std::endl flushes - -/** - * Haskell code generator. - * - */ -class t_hs_generator : public t_oop_generator { -public: - t_hs_generator(t_program* program, - const map<string, string>& parsed_options, - const string& option_string) - : t_oop_generator(program) { - (void)option_string; - std::map<std::string, std::string>::const_iterator iter; - - /* no options yet */ - for( iter = parsed_options.begin(); iter != parsed_options.end(); ++iter) { - throw "unknown option hs:" + iter->first; - } - - out_dir_base_ = "gen-hs"; - } - - /** - * Init and close methods - */ - - void init_generator() override; - void close_generator() override; - - /** - * Program-level generation functions - */ - void generate_typedef(t_typedef* ttypedef) override; - void generate_enum(t_enum* tenum) override; - void generate_const(t_const* tconst) override; - void generate_struct(t_struct* tstruct) override; - void generate_xception(t_struct* txception) override; - void generate_service(t_service* tservice) override; - - string render_const_value(t_type* type, t_const_value* value); - - /** - * Struct generation code - */ - - void generate_hs_struct(t_struct* tstruct, bool is_exception); - - void generate_hs_struct_definition(ostream& out, - t_struct* tstruct, - bool is_xception = false, - bool helper = false); - - void generate_hs_struct_reader(ostream& out, t_struct* tstruct); - - void generate_hs_struct_writer(ostream& out, t_struct* tstruct); - - void generate_hs_struct_arbitrary(ostream& out, t_struct* tstruct); - - void generate_hs_function_helpers(t_function* tfunction); - - void generate_hs_typemap(ostream& out, t_struct* tstruct); - - void generate_hs_default(ostream& out, t_struct* tstruct); - - /** - * Service-level generation functions - */ - - void generate_service_helpers(t_service* tservice); - void generate_service_interface(t_service* tservice); - void generate_service_client(t_service* tservice); - void generate_service_server(t_service* tservice); - void generate_process_function(t_service* tservice, t_function* tfunction); - - /** - * Serialization constructs - */ - - void generate_deserialize_field(ostream& out, t_field* tfield, string prefix); - - void generate_deserialize_struct(ostream& out, t_struct* tstruct, string name = ""); - - void generate_deserialize_container(ostream& out, t_type* ttype, string arg = ""); - - void generate_deserialize_set_element(ostream& out, t_set* tset); - - void generate_deserialize_list_element(ostream& out, t_list* tlist, string prefix = ""); - - void generate_deserialize_type(ostream& out, t_type* type, string arg = ""); - - void generate_serialize_type(ostream& out, t_type* type, string name = ""); - - void generate_serialize_struct(ostream& out, t_struct* tstruct, string prefix = ""); - - void generate_serialize_container(ostream& out, t_type* ttype, string prefix = ""); - - void generate_serialize_map_element(ostream& out, t_map* tmap, string kiter, string viter); - - void generate_serialize_set_element(ostream& out, t_set* tmap, string iter); - - void generate_serialize_list_element(ostream& out, t_list* tlist, string iter); - - /** - * Helper rendering functions - */ - - string hs_autogen_comment(); - string hs_language_pragma(); - string hs_imports(); - - string type_name(t_type* ttype, string function_prefix = ""); - - string field_name(string tname, string fname); - - string function_type(t_function* tfunc, - bool options = false, - bool io = false, - bool method = false); - - string type_to_enum(t_type* ttype); - - string type_to_default(t_type* ttype); - - string render_hs_type(t_type* type, bool needs_parens); - - string type_to_constructor(t_type* ttype); - - string render_hs_type_for_function_name(t_type* type); - -private: - ofstream_with_content_based_conditional_update f_types_; - ofstream_with_content_based_conditional_update f_consts_; - ofstream_with_content_based_conditional_update f_service_; - ofstream_with_content_based_conditional_update f_iface_; - ofstream_with_content_based_conditional_update f_client_; -}; - -/** - * Prepares for file generation by opening up the necessary file output - * streams. - * - * @param tprogram The program to generate - */ -void t_hs_generator::init_generator() { - // Make output directory - MKDIR(get_out_dir().c_str()); - - // Make output file - string pname = capitalize(program_name_); - string f_types_name = get_out_dir() + pname + "_Types.hs"; - f_types_.open(f_types_name.c_str()); - - string f_consts_name = get_out_dir() + pname + "_Consts.hs"; - f_consts_.open(f_consts_name.c_str()); - - // Print header - f_types_ << hs_language_pragma() << endl; - f_types_ << hs_autogen_comment() << endl; - f_types_ << "module " << pname << "_Types where" << endl; - f_types_ << hs_imports() << endl; - - f_consts_ << hs_language_pragma() << endl; - f_consts_ << hs_autogen_comment() << endl; - f_consts_ << "module " << pname << "_Consts where" << endl; - f_consts_ << hs_imports() << endl; - f_consts_ << "import " << pname << "_Types" << endl; -} - -string t_hs_generator::hs_language_pragma() { - return string( - "{-# LANGUAGE DeriveDataTypeable #-}\n" - "{-# LANGUAGE DeriveGeneric #-}\n" - "{-# LANGUAGE OverloadedStrings #-}\n" - "{-# OPTIONS_GHC -fno-warn-missing-fields #-}\n" - "{-# OPTIONS_GHC -fno-warn-missing-signatures #-}\n" - "{-# OPTIONS_GHC -fno-warn-name-shadowing #-}\n" - "{-# OPTIONS_GHC -fno-warn-unused-imports #-}\n" - "{-# OPTIONS_GHC -fno-warn-unused-matches #-}\n"); -} - -/** - * Autogen'd comment - */ -string t_hs_generator::hs_autogen_comment() { - return string("-----------------------------------------------------------------\n") - + "-- Autogenerated by Thrift Compiler (" + THRIFT_VERSION + ") --\n" - + "-- --\n" - + "-- DO NOT EDIT UNLESS YOU ARE SURE YOU KNOW WHAT YOU ARE DOING --\n" - + "-----------------------------------------------------------------\n"; -} - -/** - * Prints standard thrift imports - */ -string t_hs_generator::hs_imports() { - const vector<t_program*>& includes = program_->get_includes(); - string result = string( - "import Prelude (($), (.), (>>=), (==), (++))\n" - "import qualified Prelude as P\n" - "import qualified Control.Exception as X\n" - "import qualified Control.Monad as M ( liftM, ap, when )\n" - "import Data.Functor ( (<$>) )\n" - "import qualified Data.ByteString.Lazy as LBS\n" - "import qualified Data.Hashable as H\n" - "import qualified Data.Int as I\n" - "import qualified Data.Maybe as M (catMaybes)\n" - "import qualified Data.Text.Lazy.Encoding as E ( decodeUtf8, encodeUtf8 )\n" - "import qualified Data.Text.Lazy as LT\n" - "import qualified GHC.Generics as G (Generic)\n" - "import qualified Data.Typeable as TY ( Typeable )\n" - "import qualified Data.HashMap.Strict as Map\n" - "import qualified Data.HashSet as Set\n" - "import qualified Data.Vector as Vector\n" - "import qualified Test.QuickCheck.Arbitrary as QC ( Arbitrary(..) )\n" - "import qualified Test.QuickCheck as QC ( elements )\n" - "\n" - "import qualified Thrift as T\n" - "import qualified Thrift.Types as T\n" - "import qualified Thrift.Arbitraries as T\n" - "\n"); - - for (auto include : includes) - result += "import qualified " + capitalize(include->get_name()) + "_Types\n"; - - if (includes.size() > 0) - result += "\n"; - - return result; -} - -/** - * Closes the type files - */ -void t_hs_generator::close_generator() { - // Close types file - f_types_.close(); - f_consts_.close(); -} - -/** - * Generates a typedef. Ez. - * - * @param ttypedef The type definition - */ -void t_hs_generator::generate_typedef(t_typedef* ttypedef) { - string tname = capitalize(ttypedef->get_symbolic()); - string tdef = render_hs_type(ttypedef->get_type(), false); - indent(f_types_) << "type " << tname << " = " << tdef << endl; - f_types_ << endl; -} - -/** - * Generates code for an enumerated type. - * the values. - * - * @param tenum The enumeration - */ -void t_hs_generator::generate_enum(t_enum* tenum) { - indent(f_types_) << "data " << capitalize(tenum->get_name()) << " = "; - indent_up(); - vector<t_enum_value*> constants = tenum->get_constants(); - vector<t_enum_value*>::iterator c_iter; - - bool first = true; - for (c_iter = constants.begin(); c_iter != constants.end(); ++c_iter) { - string name = capitalize(tenum->get_name()) + "_" + capitalize((*c_iter)->get_name()); - f_types_ << (first ? "" : "|"); - f_types_ << name; - first = false; - } - indent(f_types_) << "deriving (P.Show, P.Eq, G.Generic, TY.Typeable, P.Ord, P.Bounded)" << endl; - indent_down(); - - string ename = capitalize(tenum->get_name()); - - indent(f_types_) << "instance P.Enum " << ename << " where" << endl; - indent_up(); - indent(f_types_) << "fromEnum t = case t of" << endl; - indent_up(); - for (c_iter = constants.begin(); c_iter != constants.end(); ++c_iter) { - int value = (*c_iter)->get_value(); - string name = capitalize(tenum->get_name()) + "_" + capitalize((*c_iter)->get_name()); - indent(f_types_) << name << " -> " << value << endl; - } - indent_down(); - indent(f_types_) << "toEnum t = case t of" << endl; - indent_up(); - for (c_iter = constants.begin(); c_iter != constants.end(); ++c_iter) { - int value = (*c_iter)->get_value(); - string name = capitalize(tenum->get_name()) + "_" + capitalize((*c_iter)->get_name()); - indent(f_types_) << value << " -> " << name << endl; - } - indent(f_types_) << "_ -> X.throw T.ThriftException" << endl; - indent_down(); - indent_down(); - - indent(f_types_) << "instance H.Hashable " << ename << " where" << endl; - indent_up(); - indent(f_types_) << "hashWithSalt salt = H.hashWithSalt salt P.. P.fromEnum" << endl; - indent_down(); - - indent(f_types_) << "instance QC.Arbitrary " << ename << " where" << endl; - indent_up(); - indent(f_types_) << "arbitrary = QC.elements (P.enumFromTo P.minBound P.maxBound)" << endl; - indent_down(); -} - -/** - * Generate a constant value - */ -void t_hs_generator::generate_const(t_const* tconst) { - t_type* type = tconst->get_type(); - string name = decapitalize(tconst->get_name()); - - t_const_value* value = tconst->get_value(); - - indent(f_consts_) << name << " :: " << render_hs_type(type, false) << endl; - indent(f_consts_) << name << " = " << render_const_value(type, value) << endl; - f_consts_ << endl; -} - -/** - * Prints the value of a constant with the given type. Note that type checking - * is NOT performed in this function as it is always run beforehand using the - * validate_types method in main.cc - */ -string t_hs_generator::render_const_value(t_type* type, t_const_value* value) { - if (value == nullptr) - return type_to_default(type); - - type = get_true_type(type); - ostringstream out; - - if (type->is_base_type()) { - t_base_type::t_base tbase = ((t_base_type*)type)->get_base(); - switch (tbase) { - - case t_base_type::TYPE_STRING: - out << '"' << get_escaped_string(value) << '"'; - break; - - case t_base_type::TYPE_BOOL: - out << (value->get_integer() > 0 ? "P.True" : "P.False"); - break; - - case t_base_type::TYPE_I8: - case t_base_type::TYPE_I16: - case t_base_type::TYPE_I32: - case t_base_type::TYPE_I64: - out << "(" << value->get_integer() << ")"; - break; - - case t_base_type::TYPE_DOUBLE: - if (value->get_type() == t_const_value::CV_INTEGER) { - out << "(" << value->get_integer() << ")"; - } else { - out << "(" << value->get_double() << ")"; - } - break; - - default: - throw "compiler error: no const of base type " + t_base_type::t_base_name(tbase); - } - - } else if (type->is_enum()) { - t_enum* tenum = (t_enum*)type; - vector<t_enum_value*> constants = tenum->get_constants(); - for (auto & constant : constants) { - int val = constant->get_value(); - if (val == value->get_integer()) { - t_program* prog = type->get_program(); - if (prog != nullptr && prog != program_) - out << capitalize(prog->get_name()) << "_Types."; - out << capitalize(constant->get_name()); - break; - } - } - - } else if (type->is_struct() || type->is_xception()) { - string cname = type_name(type); - out << "default_" << cname << "{"; - - const vector<t_field*>& fields = ((t_struct*)type)->get_members(); - const map<t_const_value*, t_const_value*, t_const_value::value_compare>& val = value->get_map(); - - bool first = true; - for (auto v_iter : val) { - t_field* field = nullptr; - - for (auto f_iter : fields) - if (f_iter->get_name() == v_iter.first->get_string()) - field = f_iter; - - if (field == nullptr) - throw "type error: " + cname + " has no field " + v_iter.first->get_string(); - - string fname = v_iter.first->get_string(); - string const_value = render_const_value(field->get_type(), v_iter.second); - - out << (first ? "" : ", "); - out << field_name(cname, fname) << " = "; - if (field->get_req() == t_field::T_OPTIONAL || ((t_type*)field->get_type())->is_xception()) { - out << "P.Just "; - } - out << const_value; - first = false; - } - - out << "}"; - - } else if (type->is_map()) { - t_type* ktype = ((t_map*)type)->get_key_type(); - t_type* vtype = ((t_map*)type)->get_val_type(); - - const map<t_const_value*, t_const_value*, t_const_value::value_compare>& val = value->get_map(); - map<t_const_value*, t_const_value*, t_const_value::value_compare>::const_iterator v_iter; - - out << "(Map.fromList ["; - - bool first = true; - for (v_iter = val.begin(); v_iter != val.end(); ++v_iter) { - string key = render_const_value(ktype, v_iter->first); - string val = render_const_value(vtype, v_iter->second); - out << (first ? "" : ","); - out << "(" << key << "," << val << ")"; - first = false; - } - out << "])"; - - } else if (type->is_list() || type->is_set()) { - t_type* etype = type->is_list() ? ((t_list*)type)->get_elem_type() - : ((t_set*)type)->get_elem_type(); - - const vector<t_const_value*>& val = value->get_list(); - vector<t_const_value*>::const_iterator v_iter; - - if (type->is_set()) - out << "(Set.fromList ["; - else - out << "(Vector.fromList ["; - - bool first = true; - for (v_iter = val.begin(); v_iter != val.end(); ++v_iter) { - out << (first ? "" : ","); - out << render_const_value(etype, *v_iter); - first = false; - } - - out << "])"; - - } else { - throw "CANNOT GENERATE CONSTANT FOR TYPE: " + type->get_name(); - } - - return out.str(); -} - -/** - * Generates a "struct" - */ -void t_hs_generator::generate_struct(t_struct* tstruct) { - generate_hs_struct(tstruct, false); -} - -/** - * Generates a struct definition for a thrift exception. Basically the same - * as a struct, but also has an exception declaration. - * - * @param txception The struct definition - */ -void t_hs_generator::generate_xception(t_struct* txception) { - generate_hs_struct(txception, true); -} - -/** - * Generates a Haskell struct - */ -void t_hs_generator::generate_hs_struct(t_struct* tstruct, bool is_exception) { - generate_hs_struct_definition(f_types_, tstruct, is_exception, false); -} - -/** - * Generates a struct definition for a thrift data type. - * - * @param tstruct The struct definition - */ -void t_hs_generator::generate_hs_struct_definition(ostream& out, - t_struct* tstruct, - bool is_exception, - bool helper) { - (void)helper; - string tname = type_name(tstruct); - string name = tstruct->get_name(); - const vector<t_field*>& members = tstruct->get_members(); - - indent(out) << "data " << tname << " = " << tname; - if (members.size() > 0) { - indent_up(); - bool first = true; - for (auto member : members) { - if (first) { - indent(out) << "{ "; - first = false; - } else { - indent(out) << ", "; - } - string mname = member->get_name(); - out << field_name(tname, mname) << " :: "; - if (member->get_req() == t_field::T_OPTIONAL - || ((t_type*)member->get_type())->is_xception()) { - out << "P.Maybe "; - } - out << render_hs_type(member->get_type(), true) << endl; - } - indent(out) << "}"; - indent_down(); - } - - out << " deriving (P.Show,P.Eq,G.Generic,TY.Typeable)" << endl; - - if (is_exception) - out << "instance X.Exception " << tname << endl; - - indent(out) << "instance H.Hashable " << tname << " where" << endl; - indent_up(); - indent(out) << "hashWithSalt salt record = salt"; - for (auto member : members) { - string mname = member->get_name(); - indent(out) << " `H.hashWithSalt` " << field_name(tname, mname) << " record"; - } - indent(out) << endl; - indent_down(); - - generate_hs_struct_arbitrary(out, tstruct); - generate_hs_struct_writer(out, tstruct); - generate_hs_struct_reader(out, tstruct); - generate_hs_typemap(out, tstruct); - generate_hs_default(out, tstruct); -} - -void t_hs_generator::generate_hs_struct_arbitrary(ostream& out, t_struct* tstruct) { - string tname = type_name(tstruct); - string name = tstruct->get_name(); - const vector<t_field*>& members = tstruct->get_members(); - - indent(out) << "instance QC.Arbitrary " << tname << " where " << endl; - indent_up(); - if (members.size() > 0) { - indent(out) << "arbitrary = M.liftM " << tname; - indent_up(); - indent_up(); - indent_up(); - indent_up(); - bool first = true; - for (auto member : members) { - if (first) { - first = false; - out << " "; - } else { - indent(out) << "`M.ap`"; - } - out << "("; - if (member->get_req() == t_field::T_OPTIONAL - || ((t_type*)member->get_type())->is_xception()) { - out << "M.liftM P.Just "; - } - out << "QC.arbitrary)" << endl; - } - indent_down(); - indent_down(); - indent_down(); - indent_down(); - - // Shrink - indent(out) << "shrink obj | obj == default_" << tname << " = []" << endl; - indent(out) << " | P.otherwise = M.catMaybes" << endl; - indent_up(); - first = true; - for (auto member : members) { - if (first) { - first = false; - indent(out) << "[ "; - } else { - indent(out) << ", "; - } - string fname = field_name(tname, member->get_name()); - out << "if obj == default_" << tname; - out << "{" << fname << " = " << fname << " obj} "; - out << "then P.Nothing "; - out << "else P.Just $ default_" << tname; - out << "{" << fname << " = " << fname << " obj}" << endl; - } - indent(out) << "]" << endl; - indent_down(); - } else { /* 0 == members.size() */ - indent(out) << "arbitrary = QC.elements [" << tname << "]" << endl; - } - indent_down(); -} - -/** - * Generates the read method for a struct - */ -void t_hs_generator::generate_hs_struct_reader(ostream& out, t_struct* tstruct) { - const vector<t_field*>& fields = tstruct->get_members(); - - string sname = type_name(tstruct); - string id = tmp("_id"); - string val = tmp("_val"); - - indent(out) << "to_" << sname << " :: T.ThriftVal -> " << sname << endl; - indent(out) << "to_" << sname << " (T.TStruct fields) = " << sname << "{" << endl; - indent_up(); - - bool first = true; - - // Generate deserialization code for known cases - for (auto field : fields) { - int32_t key = field->get_key(); - string etype = type_to_enum(field->get_type()); - string fname = field->get_name(); - - if (first) { - first = false; - } else { - out << "," << endl; - } - - // Fill in Field - indent(out) << field_name(sname, fname) << " = "; - - out << "P.maybe ("; - if (field->get_req() == t_field::T_REQUIRED) { - out << "P.error \"Missing required field: " << fname << "\""; - } else { - if ((field->get_req() == t_field::T_OPTIONAL - || ((t_type*)field->get_type())->is_xception()) && field->get_value() == nullptr) { - out << "P.Nothing"; - } else { - out << field_name(sname, fname) << " default_" << sname; - } - } - out << ") "; - - out << "(\\(_," << val << ") -> "; - if (field->get_req() == t_field::T_OPTIONAL - || ((t_type*)field->get_type())->is_xception()) - out << "P.Just "; - generate_deserialize_field(out, field, val); - out << ")"; - out << " (Map.lookup (" << key << ") fields)"; - } - - out << endl; - indent(out) << "}" << endl; - indent_down(); - - // read - string tmap = type_name(tstruct, "typemap_"); - indent(out) << "to_" << sname << " _ = P.error \"not a struct\"" << endl; - - indent(out) << "read_" << sname << " :: T.Protocol p => p -> P.IO " << sname - << endl; - indent(out) << "read_" << sname << " iprot = to_" << sname; - out << " <$> T.readVal iprot (T.T_STRUCT " << tmap << ")" << endl; - - indent(out) << "decode_" << sname - << " :: T.StatelessProtocol p => p -> LBS.ByteString -> " << sname << endl; - indent(out) << "decode_" << sname << " iprot bs = to_" << sname << " $ "; - out << "T.deserializeVal iprot (T.T_STRUCT " << tmap << ") bs" << endl; -} - -void t_hs_generator::generate_hs_struct_writer(ostream& out, t_struct* tstruct) { - string name = type_name(tstruct); - const vector<t_field*>& fields = tstruct->get_sorted_members(); - string str = tmp("_str"); - string f = tmp("_f"); - string v = tmp("_v"); - - indent(out) << "from_" << name << " :: " << name << " -> T.ThriftVal" << endl; - indent(out) << "from_" << name << " record = T.TStruct $ Map.fromList "; - indent_up(); - - // Get Exceptions - bool hasExn = false; - for (auto field : fields) { - if (((t_type*)field->get_type())->is_xception()) { - hasExn = true; - break; - } - } - - bool isfirst = true; - if (hasExn) { - out << endl; - indent(out) << "(let exns = M.catMaybes "; - indent_up(); - for (auto field : fields) { - if (((t_type*)field->get_type())->is_xception()) { - if (isfirst) { - out << "[ "; - isfirst = false; - } else { - out << ", "; - } - string mname = field->get_name(); - int32_t key = field->get_key(); - out << "(\\" << v << " -> (" << key << ", (\"" << mname << "\","; - generate_serialize_type(out, field->get_type(), v); - out << "))) <$> " << field_name(name, mname) << " record"; - } - } - if (!isfirst) { - out << "]" << endl; - } - indent_down(); - indent(out) << "in if P.not (P.null exns) then exns else "; - indent_up(); - } else { - out << "$ "; - } - - out << "M.catMaybes" << endl; - // Get the Rest - isfirst = true; - for (auto field : fields) { - // Write field header - if (isfirst) { - indent(out) << "[ "; - isfirst = false; - } else { - indent(out) << ", "; - } - string mname = field->get_name(); - int32_t key = field->get_key(); - out << "(\\"; - out << v << " -> "; - if (field->get_req() != t_field::T_OPTIONAL - && !((t_type*)field->get_type())->is_xception()) { - out << "P.Just "; - } - out << "(" << key << ", (\"" << mname << "\","; - generate_serialize_type(out, field->get_type(), v); - out << "))) "; - if (field->get_req() != t_field::T_OPTIONAL - && !((t_type*)field->get_type())->is_xception()) { - out << "$"; - } else { - out << "<$>"; - } - out << " " << field_name(name, mname) << " record" << endl; - } - - // Write the struct map - if (isfirst) { - indent(out) << "[]" << endl; - } else { - indent(out) << "]" << endl; - } - if (hasExn) { - indent(out) << ")" << endl; - indent_down(); - } - indent_down(); - - // write - indent(out) << "write_" << name << " :: T.Protocol p => p -> " << name - << " -> P.IO ()" << endl; - indent(out) << "write_" << name << " oprot record = T.writeVal oprot $ from_"; - out << name << " record" << endl; - - // encode - indent(out) << "encode_" << name << " :: T.StatelessProtocol p => p -> " << name - << " -> LBS.ByteString" << endl; - indent(out) << "encode_" << name << " oprot record = T.serializeVal oprot $ "; - out << "from_" << name << " record" << endl; -} - -/** - * Generates a thrift service. - * - * @param tservice The service definition - */ -void t_hs_generator::generate_service(t_service* tservice) { - string f_service_name = get_out_dir() + capitalize(service_name_) + ".hs"; - f_service_.open(f_service_name.c_str()); - - f_service_ << hs_language_pragma() << endl; - f_service_ << hs_autogen_comment() << endl; - f_service_ << "module " << capitalize(service_name_) << " where" << endl; - f_service_ << hs_imports() << endl; - - if (tservice->get_extends()) { - f_service_ << "import qualified " << capitalize(tservice->get_extends()->get_name()) << endl; - } - - f_service_ << "import " << capitalize(program_name_) << "_Types" << endl; - f_service_ << "import qualified " << capitalize(service_name_) << "_Iface as Iface" << endl; - - // Generate the three main parts of the service - generate_service_helpers(tservice); - generate_service_interface(tservice); - generate_service_client(tservice); - generate_service_server(tservice); - - // Close service file - f_service_.close(); -} - -/** - * Generates helper functions for a service. - * - * @param tservice The service to generate a header definition for - */ -void t_hs_generator::generate_service_helpers(t_service* tservice) { - vector<t_function*> functions = tservice->get_functions(); - vector<t_function*>::iterator f_iter; - - indent(f_service_) << "-- HELPER FUNCTIONS AND STRUCTURES --" << endl; - indent(f_service_) << endl; - - for (f_iter = functions.begin(); f_iter != functions.end(); ++f_iter) { - t_struct* ts = (*f_iter)->get_arglist(); - generate_hs_struct_definition(f_service_, ts, false); - generate_hs_function_helpers(*f_iter); - } -} - -/** - * Generates a struct and helpers for a function. - * - * @param tfunction The function - */ -void t_hs_generator::generate_hs_function_helpers(t_function* tfunction) { - t_struct result(program_, field_name(tfunction->get_name(), "result")); - t_field success(tfunction->get_returntype(), "success", 0); - - if (!tfunction->get_returntype()->is_void()) - result.append(&success); - - t_struct* xs = tfunction->get_xceptions(); - const vector<t_field*>& fields = xs->get_members(); - - vector<t_field*>::const_iterator f_iter; - for (f_iter = fields.begin(); f_iter != fields.end(); ++f_iter) - result.append(*f_iter); - - generate_hs_struct_definition(f_service_, &result, false); -} - -/** - * Generate the map from field names to (type, id) - * @param tstruct the Struct - */ -void t_hs_generator::generate_hs_typemap(ostream& out, t_struct* tstruct) { - string name = type_name(tstruct); - const vector<t_field*>& fields = tstruct->get_sorted_members(); - - indent(out) << "typemap_" << name << " :: T.TypeMap" << endl; - indent(out) << "typemap_" << name << " = Map.fromList ["; - bool first = true; - for (auto field : fields) { - string mname = field->get_name(); - if (!first) { - out << ","; - } - - t_type* type = get_true_type(field->get_type()); - int32_t key = field->get_key(); - out << "(" << key << ",(\"" << mname << "\"," << type_to_enum(type) << "))"; - first = false; - } - out << "]" << endl; -} - -/** - * generate the struct with default values filled in - * @param tstruct the Struct - */ -void t_hs_generator::generate_hs_default(ostream& out, t_struct* tstruct) { - string name = type_name(tstruct); - string fname = type_name(tstruct, "default_"); - const vector<t_field*>& fields = tstruct->get_sorted_members(); - - indent(out) << fname << " :: " << name << endl; - indent(out) << fname << " = " << name << "{" << endl; - indent_up(); - bool first = true; - for (auto field : fields) { - string mname = field->get_name(); - if (first) { - first = false; - } else { - out << "," << endl; - } - - t_type* type = get_true_type(field->get_type()); - t_const_value* value = field->get_value(); - indent(out) << field_name(name, mname) << " = "; - if (field->get_req() == t_field::T_OPTIONAL - || ((t_type*)field->get_type())->is_xception()) { - if (value == nullptr) { - out << "P.Nothing"; - } else { - out << "P.Just " << render_const_value(type, value); - } - } else { - out << render_const_value(type, value); - } - } - out << "}" << endl; - indent_down(); -} - -/** - * Generates a service interface definition. - * - * @param tservice The service to generate a header definition for - */ -void t_hs_generator::generate_service_interface(t_service* tservice) { - string f_iface_name = get_out_dir() + capitalize(service_name_) + "_Iface.hs"; - f_iface_.open(f_iface_name.c_str()); - - f_iface_ << hs_language_pragma() << endl; - f_iface_ << hs_autogen_comment() << endl; - - f_iface_ << "module " << capitalize(service_name_) << "_Iface where" << endl; - - f_iface_ << hs_imports() << endl; - f_iface_ << "import " << capitalize(program_name_) << "_Types" << endl; - f_iface_ << endl; - - string sname = capitalize(service_name_); - if (tservice->get_extends() != nullptr) { - string extends = type_name(tservice->get_extends()); - - indent(f_iface_) << "import " << extends << "_Iface" << endl; - indent(f_iface_) << "class " << extends << "_Iface a => " << sname << "_Iface a where" << endl; - - } else { - indent(f_iface_) << "class " << sname << "_Iface a where" << endl; - } - - indent_up(); - - vector<t_function*> functions = tservice->get_functions(); - vector<t_function*>::iterator f_iter; - for (f_iter = functions.begin(); f_iter != functions.end(); ++f_iter) { - string ft = function_type(*f_iter, true, true, true); - indent(f_iface_) << decapitalize((*f_iter)->get_name()) << " :: a -> " << ft << endl; - } - - indent_down(); - f_iface_.close(); -} - -/** - * Generates a service client definition. Note that in Haskell, the client doesn't implement iface. - *This is because - * The client does not (and should not have to) deal with arguments being Nothing. - * - * @param tservice The service to generate a server for. - */ -void t_hs_generator::generate_service_client(t_service* tservice) { - string f_client_name = get_out_dir() + capitalize(service_name_) + "_Client.hs"; - f_client_.open(f_client_name.c_str()); - f_client_ << hs_language_pragma() << endl; - f_client_ << hs_autogen_comment() << endl; - - vector<t_function*> functions = tservice->get_functions(); - vector<t_function*>::const_iterator f_iter; - - string extends = ""; - string exports = ""; - - bool first = true; - for (f_iter = functions.begin(); f_iter != functions.end(); ++f_iter) { - exports += (first ? "" : ","); - string funname = (*f_iter)->get_name(); - exports += decapitalize(funname); - first = false; - } - - string sname = capitalize(service_name_); - indent(f_client_) << "module " << sname << "_Client(" << exports << ") where" << endl; - - if (tservice->get_extends() != nullptr) { - extends = type_name(tservice->get_extends()); - indent(f_client_) << "import " << extends << "_Client" << endl; - } - - indent(f_client_) << "import qualified Data.IORef as R" << endl; - indent(f_client_) << hs_imports() << endl; - indent(f_client_) << "import " << capitalize(program_name_) << "_Types" << endl; - indent(f_client_) << "import " << capitalize(service_name_) << endl; - - // DATS RITE A GLOBAL VAR - indent(f_client_) << "seqid = R.newIORef 0" << endl; - - // Generate client method implementations - for (f_iter = functions.begin(); f_iter != functions.end(); ++f_iter) { - t_struct* arg_struct = (*f_iter)->get_arglist(); - const vector<t_field*>& fields = arg_struct->get_members(); - vector<t_field*>::const_iterator fld_iter; - string funname = (*f_iter)->get_name(); - - string fargs = ""; - for (fld_iter = fields.begin(); fld_iter != fields.end(); ++fld_iter) - fargs += " arg_" + (*fld_iter)->get_name(); - - // Open function - indent(f_client_) << decapitalize(funname) << " (ip,op)" << fargs << " = do" << endl; - indent_up(); - indent(f_client_) << "send_" << funname << " op" << fargs; - - f_client_ << endl; - - if (!(*f_iter)->is_oneway()) - indent(f_client_) << "recv_" << funname << " ip" << endl; - - indent_down(); - - indent(f_client_) << "send_" << funname << " op" << fargs << " = do" << endl; - indent_up(); - - indent(f_client_) << "seq <- seqid" << endl; - indent(f_client_) << "seqn <- R.readIORef seq" << endl; - string argsname = capitalize((*f_iter)->get_name() + "_args"); - - // Serialize the request header - string fname = (*f_iter)->get_name(); - string msgType = (*f_iter)->is_oneway() ? "T.M_ONEWAY" : "T.M_CALL"; - indent(f_client_) << "T.writeMessage op (\"" << fname << "\", " << msgType << ", seqn) $" - << endl; - indent_up(); - indent(f_client_) << "write_" << argsname << " op (" << argsname << "{"; - - bool first = true; - for (auto field : fields) { - string fieldname = field->get_name(); - f_client_ << (first ? "" : ","); - f_client_ << field_name(argsname, fieldname) << "="; - if (field->get_req() == t_field::T_OPTIONAL - || ((t_type*)field->get_type())->is_xception()) - f_client_ << "P.Just "; - f_client_ << "arg_" << fieldname; - first = false; - } - f_client_ << "})" << endl; - indent_down(); - indent_down(); - - if (!(*f_iter)->is_oneway()) { - string resultname = capitalize((*f_iter)->get_name() + "_result"); - t_struct noargs(program_); - - string funname = string("recv_") + (*f_iter)->get_name(); - t_function recv_function((*f_iter)->get_returntype(), funname, &noargs); - - // Open function - indent(f_client_) << funname << " ip = do" << endl; - indent_up(); - - indent(f_client_) << "T.readMessage ip $ \\(fname, mtype, rseqid) -> do" << endl; - indent_up(); - indent(f_client_) << "M.when (mtype == T.M_EXCEPTION) $ do { exn <- T.readAppExn ip ; " - "X.throw exn }" << endl; - - indent(f_client_) << "res <- read_" << resultname << " ip" << endl; - - t_struct* xs = (*f_iter)->get_xceptions(); - const vector<t_field*>& xceptions = xs->get_members(); - - for (auto xception : xceptions) { - indent(f_client_) << "P.maybe (P.return ()) X.throw (" - << field_name(resultname, xception->get_name()) << " res)" << endl; - } - - if (!(*f_iter)->get_returntype()->is_void()) - indent(f_client_) << "P.return $ " << field_name(resultname, "success") << " res" << endl; - else - indent(f_client_) << "P.return ()" << endl; - - // Close function - indent_down(); - indent_down(); - } - } - - f_client_.close(); -} - -/** - * Generates a service server definition. - * - * @param tservice The service to generate a server for. - */ -void t_hs_generator::generate_service_server(t_service* tservice) { - // Generate the dispatch methods - vector<t_function*> functions = tservice->get_functions(); - vector<t_function*>::iterator f_iter; - - // Generate the process subfunctions - for (f_iter = functions.begin(); f_iter != functions.end(); ++f_iter) - generate_process_function(tservice, *f_iter); - - indent(f_service_) << "proc_ handler (iprot,oprot) (name,typ,seqid) = case name of" << endl; - indent_up(); - - for (f_iter = functions.begin(); f_iter != functions.end(); ++f_iter) { - string fname = (*f_iter)->get_name(); - indent(f_service_) << "\"" << fname << "\" -> process_" << decapitalize(fname) - << " (seqid,iprot,oprot,handler)" << endl; - } - - indent(f_service_) << "_ -> "; - if (tservice->get_extends() != nullptr) { - f_service_ << type_name(tservice->get_extends()) - << ".proc_ handler (iprot,oprot) (name,typ,seqid)" << endl; - - } else { - f_service_ << "do" << endl; - indent_up(); - indent(f_service_) << "_ <- T.readVal iprot (T.T_STRUCT Map.empty)" << endl; - indent(f_service_) << "T.writeMessage oprot (name,T.M_EXCEPTION,seqid) $" << endl; - indent_up(); - indent(f_service_) << "T.writeAppExn oprot (T.AppExn T.AE_UNKNOWN_METHOD (\"Unknown function " - "\" ++ LT.unpack name))" << endl; - indent_down(); - indent_down(); - } - - indent_down(); - - // Generate the server implementation - indent(f_service_) << "process handler (iprot, oprot) = do" << endl; - indent_up(); - - indent(f_service_) << "T.readMessage iprot (" << endl; - indent(f_service_) << " proc_ handler (iprot,oprot))" << endl; - indent(f_service_) << "P.return P.True" << endl; - indent_down(); -} - -bool hasNoArguments(t_function* func) { - return (func->get_arglist()->get_members().empty()); -} - -string t_hs_generator::render_hs_type_for_function_name(t_type* type) { - string type_str = render_hs_type(type, false); - std::string::size_type found = -1; - - while (true) { - found = type_str.find_first_of("[]. ", found + 1); - if (string::npos == size_t(found)) { - break; - } - - if (type_str[found] == '.') - type_str[found] = '_'; - else - type_str[found] = 'Z'; - } - return type_str; -} - -/** - * Generates a process function definition. - * - * @param tfunction The function to write a dispatcher for - */ -void t_hs_generator::generate_process_function(t_service* tservice, t_function* tfunction) { - (void)tservice; - // Open function - string funname = decapitalize(tfunction->get_name()); - indent(f_service_) << "process_" << funname << " (seqid, iprot, oprot, handler) = do" << endl; - indent_up(); - - string argsname = capitalize(tfunction->get_name()) + "_args"; - string resultname = capitalize(tfunction->get_name()) + "_result"; - - // Generate the function call - t_struct* arg_struct = tfunction->get_arglist(); - const vector<t_field*>& fields = arg_struct->get_members(); - vector<t_field*>::const_iterator f_iter; - - indent(f_service_) << "args <- read_" << argsname << " iprot" << endl; - - t_struct* xs = tfunction->get_xceptions(); - const vector<t_field*>& xceptions = xs->get_members(); - vector<t_field*>::const_iterator x_iter; - - size_t n = xceptions.size() + 1; - // Try block for a function with exceptions - if (n > 0) { - for (size_t i = 0; i < n; i++) { - indent(f_service_) << "(X.catch" << endl; - indent_up(); - } - } - - if (n > 0) { - indent(f_service_) << "(do" << endl; - indent_up(); - } - indent(f_service_); - - if (!tfunction->is_oneway() && !tfunction->get_returntype()->is_void()) - f_service_ << "val <- "; - - f_service_ << "Iface." << decapitalize(tfunction->get_name()) << " handler"; - for (f_iter = fields.begin(); f_iter != fields.end(); ++f_iter) - f_service_ << " (" << field_name(argsname, (*f_iter)->get_name()) << " args)"; - - if (!tfunction->is_oneway() && !tfunction->get_returntype()->is_void()) { - f_service_ << endl; - indent(f_service_) << "let res = default_" << resultname << "{" - << field_name(resultname, "success") << " = val}"; - - } else if (!tfunction->is_oneway()) { - f_service_ << endl; - indent(f_service_) << "let res = default_" << resultname; - } - f_service_ << endl; - - // Shortcut out here for oneway functions - if (tfunction->is_oneway()) { - indent(f_service_) << "P.return ()"; - } else { - indent(f_service_) << "T.writeMessage oprot (\"" << tfunction->get_name() - << "\", T.M_REPLY, seqid) $" << endl; - indent_up(); - indent(f_service_) << "write_" << resultname << " oprot res"; - indent_down(); - } - if (n > 0) { - f_service_ << ")"; - indent_down(); - } - f_service_ << endl; - - if (n > 0) { - for (x_iter = xceptions.begin(); x_iter != xceptions.end(); ++x_iter) { - indent(f_service_) << "(\\e -> do" << endl; - indent_up(); - - if (!tfunction->is_oneway()) { - indent(f_service_) << "let res = default_" << resultname << "{" - << field_name(resultname, (*x_iter)->get_name()) << " = P.Just e}" - << endl; - indent(f_service_) << "T.writeMessage oprot (\"" << tfunction->get_name() - << "\", T.M_REPLY, seqid) $" << endl; - indent_up(); - indent(f_service_) << "write_" << resultname << " oprot res"; - indent_down(); - } else { - indent(f_service_) << "P.return ()"; - } - - f_service_ << "))" << endl; - indent_down(); - indent_down(); - } - indent(f_service_) << "((\\_ -> do" << endl; - indent_up(); - - if (!tfunction->is_oneway()) { - indent(f_service_) << "T.writeMessage oprot (\"" << tfunction->get_name() - << "\", T.M_EXCEPTION, seqid) $" << endl; - indent_up(); - indent(f_service_) << "T.writeAppExn oprot (T.AppExn T.AE_UNKNOWN \"\")"; - indent_down(); - } else { - indent(f_service_) << "P.return ()"; - } - - f_service_ << ") :: X.SomeException -> P.IO ()))" << endl; - indent_down(); - indent_down(); - } - // Close function - indent_down(); -} - -/** - * Deserializes a field of any type. - */ -void t_hs_generator::generate_deserialize_field(ostream& out, t_field* tfield, string prefix) { - (void)prefix; - t_type* type = tfield->get_type(); - generate_deserialize_type(out, type, prefix); -} - -/** - * Deserializes a field of any type. - */ -void t_hs_generator::generate_deserialize_type(ostream& out, t_type* type, string arg) { - type = get_true_type(type); - string val = tmp("_val"); - out << "(case " << arg << " of {" << type_to_constructor(type) << " " << val << " -> "; - - if (type->is_void()) - throw "CANNOT GENERATE DESERIALIZE CODE FOR void TYPE"; - - if (type->is_struct() || type->is_xception()) { - generate_deserialize_struct(out, (t_struct*)type, val); - - } else if (type->is_container()) { - generate_deserialize_container(out, type, val); - - } else if (type->is_base_type()) { - t_base_type::t_base tbase = ((t_base_type*)type)->get_base(); - if (tbase == t_base_type::TYPE_STRING && !type->is_binary()) { - out << "E.decodeUtf8 "; - } - out << val; - if (type->is_binary()) { - // Since wire type of binary is the same as string, we actually receive T.TString not - // T.TBinary - out << "; T.TString " << val << " -> " << val; - } - } else if (type->is_enum()) { - out << "P.toEnum $ P.fromIntegral " << val; - - } else { - throw "DO NOT KNOW HOW TO DESERIALIZE TYPE " + type->get_name(); - } - out << "; _ -> P.error \"wrong type\"})"; -} - -/** - * Generates an unserializer for a struct, calling read() - */ -void t_hs_generator::generate_deserialize_struct(ostream& out, t_struct* tstruct, string name) { - - out << "(" << type_name(tstruct, "to_") << " (T.TStruct " << name << "))"; -} - -/** - * Serialize a container by writing out the header followed by - * data and then a footer. - */ -void t_hs_generator::generate_deserialize_container(ostream& out, t_type* ttype, string arg) { - - string val = tmp("_v"); - // Declare variables, read header - if (ttype->is_map()) { - string key = tmp("_k"); - out << "(Map.fromList $ P.map (\\(" << key << "," << val << ") -> ("; - generate_deserialize_type(out, ((t_map*)ttype)->get_key_type(), key); - - out << ","; - generate_deserialize_type(out, ((t_map*)ttype)->get_val_type(), val); - - out << ")) " << arg << ")"; - - } else if (ttype->is_set()) { - out << "(Set.fromList $ P.map (\\" << val << " -> "; - generate_deserialize_type(out, ((t_set*)ttype)->get_elem_type(), val); - out << ") " << arg << ")"; - - } else if (ttype->is_list()) { - out << "(Vector.fromList $ P.map (\\" << val << " -> "; - generate_deserialize_type(out, ((t_list*)ttype)->get_elem_type(), val); - out << ") " << arg << ")"; - } -} - -/** - * Serializes a field of any type. - * - * @param tfield The field to serialize - * @param prefix Name to prepend to field name - */ -void t_hs_generator::generate_serialize_type(ostream& out, t_type* type, string name) { - - type = get_true_type(type); - // Do nothing for void types - if (type->is_void()) - throw "CANNOT GENERATE SERIALIZE CODE FOR void TYPE"; - - if (type->is_struct() || type->is_xception()) { - generate_serialize_struct(out, (t_struct*)type, name); - - } else if (type->is_container()) { - generate_serialize_container(out, type, name); - - } else if (type->is_base_type() || type->is_enum()) { - if (type->is_base_type()) { - t_base_type::t_base tbase = ((t_base_type*)type)->get_base(); - out << type_to_constructor(type) << " "; - if (tbase == t_base_type::TYPE_STRING && !type->is_binary()) { - out << "$ E.encodeUtf8 "; - } - out << name; - - } else if (type->is_enum()) { - string ename = capitalize(type->get_name()); - out << "T.TI32 $ P.fromIntegral $ P.fromEnum " << name; - } - - } else { - throw "DO NOT KNOW HOW TO SERIALIZE FIELD OF TYPE " + type->get_name(); - } -} - -/** - * Serializes all the members of a struct. - * - * @param tstruct The struct to serialize - * @param prefix String prefix to attach to all fields - */ -void t_hs_generator::generate_serialize_struct(ostream& out, t_struct* tstruct, string prefix) { - out << type_name(tstruct, "from_") << " " << prefix; -} - -void t_hs_generator::generate_serialize_container(ostream& out, t_type* ttype, string prefix) { - string k = tmp("_k"); - string v = tmp("_v"); - - if (ttype->is_map()) { - t_type* ktype = ((t_map*)ttype)->get_key_type(); - t_type* vtype = ((t_map*)ttype)->get_val_type(); - out << "T.TMap " << type_to_enum(ktype) << " " << type_to_enum(vtype); - out << " $ P.map (\\(" << k << "," << v << ") -> ("; - generate_serialize_type(out, ktype, k); - out << ", "; - generate_serialize_type(out, vtype, v); - out << ")) $ Map.toList " << prefix; - - } else if (ttype->is_set()) { - out << "T.TSet " << type_to_enum(((t_set*)ttype)->get_elem_type()); - out << " $ P.map (\\" << v << " -> "; - generate_serialize_type(out, ((t_set*)ttype)->get_elem_type(), v); - out << ") $ Set.toList " << prefix; - - } else if (ttype->is_list()) { - out << "T.TList " << type_to_enum(((t_list*)ttype)->get_elem_type()); - out << " $ P.map (\\" << v << " -> "; - generate_serialize_type(out, ((t_list*)ttype)->get_elem_type(), v); - out << ") $ Vector.toList " << prefix; - } -} - -string t_hs_generator::function_type(t_function* tfunc, bool options, bool io, bool method) { - string result = ""; - - const vector<t_field*>& fields = tfunc->get_arglist()->get_members(); - for (auto field : fields) { - if (field->get_req() == t_field::T_OPTIONAL - || ((t_type*)field->get_type())->is_xception()) - result += "P.Maybe "; - result += render_hs_type(field->get_type(), options); - result += " -> "; - } - - if (fields.empty() && !method) - result += "() -> "; - - if (io) - result += "P.IO "; - - result += render_hs_type(tfunc->get_returntype(), io); - return result; -} - -string t_hs_generator::type_name(t_type* ttype, string function_prefix) { - string prefix = ""; - t_program* program = ttype->get_program(); - - if (program != nullptr && program != program_) - if (!ttype->is_service()) - prefix = capitalize(program->get_name()) + "_Types."; - - return prefix + function_prefix + capitalize(ttype->get_name()); -} - -string t_hs_generator::field_name(string tname, string fname) { - return decapitalize(tname) + "_" + fname; -} - -/** - * Converts the parse type to a Protocol.t_type enum - */ -string t_hs_generator::type_to_enum(t_type* type) { - type = get_true_type(type); - - if (type->is_base_type()) { - t_base_type::t_base tbase = ((t_base_type*)type)->get_base(); - switch (tbase) { - case t_base_type::TYPE_VOID: - return "T.T_VOID"; - case t_base_type::TYPE_STRING: - return type->is_binary() ? "T.T_BINARY" : "T.T_STRING"; - case t_base_type::TYPE_BOOL: - return "T.T_BOOL"; - case t_base_type::TYPE_I8: - return "T.T_BYTE"; - case t_base_type::TYPE_I16: - return "T.T_I16"; - case t_base_type::TYPE_I32: - return "T.T_I32"; - case t_base_type::TYPE_I64: - return "T.T_I64"; - case t_base_type::TYPE_DOUBLE: - return "T.T_DOUBLE"; - } - - } else if (type->is_enum()) { - return "T.T_I32"; - - } else if (type->is_struct() || type->is_xception()) { - return "(T.T_STRUCT " + type_name((t_struct*)type, "typemap_") + ")"; - - } else if (type->is_map()) { - string ktype = type_to_enum(((t_map*)type)->get_key_type()); - string vtype = type_to_enum(((t_map*)type)->get_val_type()); - return "(T.T_MAP " + ktype + " " + vtype + ")"; - - } else if (type->is_set()) { - return "(T.T_SET " + type_to_enum(((t_set*)type)->get_elem_type()) + ")"; - - } else if (type->is_list()) { - return "(T.T_LIST " + type_to_enum(((t_list*)type)->get_elem_type()) + ")"; - } - - throw "INVALID TYPE IN type_to_enum: " + type->get_name(); -} - -/** - * Converts the parse type to a default value - */ -string t_hs_generator::type_to_default(t_type* type) { - type = get_true_type(type); - - if (type->is_base_type()) { - t_base_type::t_base tbase = ((t_base_type*)type)->get_base(); - switch (tbase) { - case t_base_type::TYPE_VOID: - return "P.error \"No default value for type T_VOID\""; - case t_base_type::TYPE_STRING: - return "\"\""; - case t_base_type::TYPE_BOOL: - return "P.False"; - case t_base_type::TYPE_I8: - return "0"; - case t_base_type::TYPE_I16: - return "0"; - case t_base_type::TYPE_I32: - return "0"; - case t_base_type::TYPE_I64: - return "0"; - case t_base_type::TYPE_DOUBLE: - return "0"; - } - - } else if (type->is_enum()) { - return "(P.toEnum 0)"; - - } else if (type->is_struct() || type->is_xception()) { - return type_name((t_struct*)type, "default_"); - - } else if (type->is_map()) { - return "Map.empty"; - - } else if (type->is_set()) { - return "Set.empty"; - - } else if (type->is_list()) { - return "Vector.empty"; - } - - throw "INVALID TYPE IN type_to_default: " + type->get_name(); -} - -/** - * Converts the parse type to an haskell type - */ -string t_hs_generator::render_hs_type(t_type* type, bool needs_parens) { - type = get_true_type(type); - string type_repr; - - if (type->is_base_type()) { - t_base_type::t_base tbase = ((t_base_type*)type)->get_base(); - switch (tbase) { - case t_base_type::TYPE_VOID: - return "()"; - case t_base_type::TYPE_STRING: - return (type->is_binary() ? "LBS.ByteString" : "LT.Text"); - case t_base_type::TYPE_BOOL: - return "P.Bool"; - case t_base_type::TYPE_I8: - return "I.Int8"; - case t_base_type::TYPE_I16: - return "I.Int16"; - case t_base_type::TYPE_I32: - return "I.Int32"; - case t_base_type::TYPE_I64: - return "I.Int64"; - case t_base_type::TYPE_DOUBLE: - return "P.Double"; - } - - } else if (type->is_enum()) { - return type_name((t_enum*)type); - - } else if (type->is_struct() || type->is_xception()) { - return type_name((t_struct*)type); - - } else if (type->is_map()) { - t_type* ktype = ((t_map*)type)->get_key_type(); - t_type* vtype = ((t_map*)type)->get_val_type(); - type_repr = "Map.HashMap " + render_hs_type(ktype, true) + " " + render_hs_type(vtype, true); - - } else if (type->is_set()) { - t_type* etype = ((t_set*)type)->get_elem_type(); - type_repr = "Set.HashSet " + render_hs_type(etype, true); - - } else if (type->is_list()) { - t_type* etype = ((t_list*)type)->get_elem_type(); - type_repr = "Vector.Vector " + render_hs_type(etype, true); - - } else { - throw "INVALID TYPE IN type_to_enum: " + type->get_name(); - } - - return needs_parens ? "(" + type_repr + ")" : type_repr; -} - -/** - * Converts the parse type to a haskell constructor - */ -string t_hs_generator::type_to_constructor(t_type* type) { - type = get_true_type(type); - - if (type->is_base_type()) { - t_base_type::t_base tbase = ((t_base_type*)type)->get_base(); - switch (tbase) { - case t_base_type::TYPE_VOID: - throw "invalid type: T_VOID"; - case t_base_type::TYPE_STRING: - return type->is_binary() ? "T.TBinary" : "T.TString"; - case t_base_type::TYPE_BOOL: - return "T.TBool"; - case t_base_type::TYPE_I8: - return "T.TByte"; - case t_base_type::TYPE_I16: - return "T.TI16"; - case t_base_type::TYPE_I32: - return "T.TI32"; - case t_base_type::TYPE_I64: - return "T.TI64"; - case t_base_type::TYPE_DOUBLE: - return "T.TDouble"; - } - - } else if (type->is_enum()) { - return "T.TI32"; - - } else if (type->is_struct() || type->is_xception()) { - return "T.TStruct"; - - } else if (type->is_map()) { - return "T.TMap _ _"; - - } else if (type->is_set()) { - return "T.TSet _"; - - } else if (type->is_list()) { - return "T.TList _"; - } - throw "INVALID TYPE IN type_to_enum: " + type->get_name(); -} - -THRIFT_REGISTER_GENERATOR(hs, "Haskell", "") diff --git a/compiler/cpp/tests/CMakeLists.txt b/compiler/cpp/tests/CMakeLists.txt index 57b4c09f3..0e8254158 100644 --- a/compiler/cpp/tests/CMakeLists.txt +++ b/compiler/cpp/tests/CMakeLists.txt @@ -107,7 +107,6 @@ THRIFT_ADD_COMPILER(erl "Enable compiler for Erlang" OFF) THRIFT_ADD_COMPILER(go "Enable compiler for Go" OFF) THRIFT_ADD_COMPILER(gv "Enable compiler for GraphViz" OFF) THRIFT_ADD_COMPILER(haxe "Enable compiler for Haxe" OFF) -THRIFT_ADD_COMPILER(hs "Enable compiler for Haskell" OFF) THRIFT_ADD_COMPILER(html "Enable compiler for HTML Documentation" OFF) THRIFT_ADD_COMPILER(java "Enable compiler for Java" OFF) THRIFT_ADD_COMPILER(javame "Enable compiler for Java ME" OFF) diff --git a/configure.ac b/configure.ac index 2d6d62ba2..6c9cfca58 100755 --- a/configure.ac +++ b/configure.ac @@ -70,12 +70,6 @@ AC_ARG_VAR([PERL_PREFIX], [Prefix for installing Perl modules. Default = "/usr/local/lib"]) AS_IF([test "x$PERL_PREFIX" = x], [PERL_PREFIX="/usr/local"]) -AC_ARG_VAR([CABAL_CONFIGURE_FLAGS], - [Extra flags to pass to cabal: "cabal Setup.lhs configure $CABAL_CONFIGURE_FLAGS". - (Typically used to set --user or force --global.)]) - -AC_SUBST(CABAL_CONFIGURE_FLAGS) - AC_ARG_VAR([D_IMPORT_PREFIX], [Prefix for installing D modules. [INCLUDEDIR/d2]]) AS_IF([test "x$D_IMPORT_PREFIX" = x], [D_IMPORT_PREFIX="${includedir}/d2"]) @@ -123,7 +117,6 @@ if test "$enable_libs" = "no"; then with_python="no" with_py3="no" with_ruby="no" - with_haskell="no" with_haxe="no" with_netstd="no" with_perl="no" @@ -366,24 +359,6 @@ fi AM_CONDITIONAL(WITH_RUBY, [test "$have_ruby" = "yes"]) AM_CONDITIONAL(HAVE_BUNDLER, [test "x$BUNDLER" != "x"]) -AX_THRIFT_LIB(haskell, [Haskell], yes) -have_haskell=no -RUNHASKELL=true -CABAL=true -if test "$with_haskell" = "yes"; then - AC_PATH_PROG([CABAL], [cabal]) - AC_PATH_PROG([RUNHASKELL], [runhaskell]) - if test "x$CABAL" != "x" -a "x$RUNHASKELL" != "x"; then - have_haskell="yes" - else - RUNHASKELL=true - CABAL=true - fi -fi -AC_SUBST(CABAL) -AC_SUBST(RUNHASKELL) -AM_CONDITIONAL(WITH_HASKELL, [test "$have_haskell" = "yes"]) - AX_THRIFT_LIB(go, [Go], yes) if test "$with_go" = "yes"; then AC_PATH_PROG([GO], [go]) @@ -779,7 +754,6 @@ AC_CONFIG_FILES([ lib/go/Makefile lib/go/test/Makefile lib/haxe/test/Makefile - lib/hs/Makefile lib/java/Makefile lib/js/Makefile lib/js/test/Makefile @@ -816,7 +790,6 @@ AC_CONFIG_FILES([ test/erl/Makefile test/go/Makefile test/haxe/Makefile - test/hs/Makefile test/lua/Makefile test/netstd/Makefile test/php/Makefile @@ -834,7 +807,6 @@ AC_CONFIG_FILES([ tutorial/d/Makefile tutorial/go/Makefile tutorial/haxe/Makefile - tutorial/hs/Makefile tutorial/java/Makefile tutorial/js/Makefile tutorial/netstd/Makefile @@ -863,8 +835,6 @@ if test "$have_py3" = "yes" ; then MAYBE_PY3="py3" ; else MAYBE_PY3="" ; fi AC_SUBST([MAYBE_PY3]) if test "$have_ruby" = "yes" ; then MAYBE_RUBY="rb" ; else MAYBE_RUBY="" ; fi AC_SUBST([MAYBE_RUBY]) -if test "$have_haskell" = "yes" ; then MAYBE_HASKELL="hs" ; else MAYBE_HASKELL="" ; fi -AC_SUBST([MAYBE_HASKELL]) if test "$have_perl" = "yes" ; then MAYBE_PERL="perl" ; else MAYBE_PERL="" ; fi AC_SUBST([MAYBE_PERL]) if test "$have_php" = "yes" ; then MAYBE_PHP="php" ; else MAYBE_PHP="" ; fi @@ -904,7 +874,6 @@ echo "Building Dart Library ........ : $have_dart" echo "Building .NET Standard Library : $have_netstd" echo "Building Erlang Library ...... : $have_erlang" echo "Building Go Library .......... : $have_go" -echo "Building Haskell Library ..... : $have_haskell" echo "Building Haxe Library ........ : $have_haxe" echo "Building Java Library ........ : $have_java" echo "Building Lua Library ......... : $have_lua" @@ -971,13 +940,6 @@ if test "$have_go" = "yes" ; then echo " Using Go................... : $GO" echo " Using Go version........... : $($GO version)" fi -if test "$have_haskell" = "yes" ; then - echo - echo "Haskell Library:" - echo " Using Cabal ............... : $CABAL" - echo " Using Haskell ............. : $RUNHASKELL" - echo " Using Haskell version ..... : $($RUNHASKELL --version)" -fi if test "$have_haxe" = "yes" ; then echo echo "Haxe Library:" diff --git a/contrib/Vagrantfile b/contrib/Vagrantfile index 6d2d42032..d4a7b82c9 100644 --- a/contrib/Vagrantfile +++ b/contrib/Vagrantfile @@ -68,10 +68,6 @@ sudo apt-get install -qq erlang-base erlang-eunit erlang-dev erlang-tools echo "golang-go golang-go/dashboard boolean false" | debconf-set-selections sudo apt-get -y install -qq golang golang-go -# Haskell dependencies -sudo apt-get install -qq ghc cabal-install libghc-binary-dev libghc-network-dev libghc-http-dev libghc-hashable-dev libghc-unordered-containers-dev libghc-vector-dev -sudo cabal update - # Lua dependencies sudo apt-get install -qq lua5.2 lua5.2-dev diff --git a/contrib/vagrant/centos-6.5/Vagrantfile b/contrib/vagrant/centos-6.5/Vagrantfile index 51a2239bc..fe12da7c7 100644 --- a/contrib/vagrant/centos-6.5/Vagrantfile +++ b/contrib/vagrant/centos-6.5/Vagrantfile @@ -130,14 +130,6 @@ sudo yum install -y golang golang-pkg-linux-amd64 ##################################### sudo yum install -y mono-core mono-devel mono-web-devel mono-extras mingw32-binutils mingw32-runtime mingw32-nsis -# Haskell LIB Dependencies -##################################### -wget http://sherkin.justhub.org/el6/RPMS/x86_64/justhub-release-2.0-4.0.el6.x86_64.rpm -sudo rpm -ivh justhub-release-2.0-4.0.el6.x86_64.rpm -sudo yum -y install haskell -sudo cabal update -sudo cabal install cabal-install - # Build and Test Apache Thrift ##################################### date > /etc/vagrant.provision_end @@ -41,7 +41,6 @@ <programming-language>Delphi</programming-language> <programming-language>Erlang</programming-language> <programming-language>Go</programming-language> - <programming-language>Haskell</programming-language> <programming-language>Haxe</programming-language> <programming-language>Java</programming-language> <programming-language>JavaScript</programming-language> diff --git a/doc/ReleaseManagement.md b/doc/ReleaseManagement.md index d2b6f342e..70df31cd7 100644 --- a/doc/ReleaseManagement.md +++ b/doc/ReleaseManagement.md @@ -399,8 +399,6 @@ See https://thrift.apache.org/lib/ for the current status of each external packa * Run "pub publish" and go through the google account authorization to allow it. * [dlang] Within a day, the dlang dub site https://code.dlang.org/packages/apache-thrift?tab=info should pick up the release based on the tag. No action is needed. -* [haskell] https://hackage.haskell.org/package/thrift - https://jira.apache.org/jira/browse/THRIFT-4698 * [npmjs] @jfarrell is the only one who can do this right now. https://issues.apache.org/jira/browse/THRIFT-4688 * [perl] A submission to CPAN is necessary (normally jeking3 does this): diff --git a/doc/install/debian.md b/doc/install/debian.md index c18487f75..92d68e9ce 100644 --- a/doc/install/debian.md +++ b/doc/install/debian.md @@ -34,8 +34,6 @@ If you would like to build Apache Thrift libraries for other programming languag * erlang-base erlang-eunit erlang-dev rebar * NetStd * apt-transport-https dotnet-sdk-5.0 aspnetcore-runtime-5.0 - * Haskell - * ghc cabal-install libghc-binary-dev libghc-network-dev libghc-http-dev * Thrift Compiler for Windows * mingw-w64 mingw-w64-x86-64-dev nsis * Rust diff --git a/lib/Makefile.am b/lib/Makefile.am index 3213aff85..56b295fc8 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -48,10 +48,6 @@ if WITH_RUBY SUBDIRS += rb endif -if WITH_HASKELL -SUBDIRS += hs -endif - if WITH_PERL SUBDIRS += perl endif diff --git a/lib/hs/CMakeLists.txt b/lib/hs/CMakeLists.txt deleted file mode 100644 index c477c9b56..000000000 --- a/lib/hs/CMakeLists.txt +++ /dev/null @@ -1,93 +0,0 @@ -# -# Licensed to the Apache Software Foundation (ASF) under one -# or more contributor license agreements. See the NOTICE file -# distributed with this work for additional information -# regarding copyright ownership. The ASF licenses this file -# to you under the Apache License, Version 2.0 (the -# "License"); you may not use this file except in compliance -# with the License. You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, -# software distributed under the License is distributed on an -# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -# KIND, either express or implied. See the License for the -# specific language governing permissions and limitations -# under the License. -# - -# Rebuild when any of these files changes -set(haskell_sources - src/Thrift.hs - src/Thrift/Arbitraries.hs - src/Thrift/Protocol.hs - src/Thrift/Protocol/Binary.hs - src/Thrift/Protocol/Compact.hs - src/Thrift/Protocol/JSON.hs - src/Thrift/Server.hs - src/Thrift/Transport.hs - src/Thrift/Transport/Empty.hs - src/Thrift/Transport/Framed.hs - src/Thrift/Transport/Handle.hs - src/Thrift/Transport/HttpClient.hs - src/Thrift/Transport/IOBuffer.hs - src/Thrift/Types.hs - thrift.cabal -) - -if(BUILD_TESTING) - list(APPEND haskell_sources - test/Spec.hs - test/BinarySpec.hs - test/CompactSpec.hs - test/JSONSpec.hs - ) - set(hs_enable_test "--enable-tests") -endif() - -set(haskell_artifacts thrift_cabal.stamp) -# Adding *.hi files so that any missing file triggers the build -foreach(SRC ${haskell_sources}) - get_filename_component(EX ${SRC} EXT) - if(${EX} STREQUAL ".hs") - file(RELATIVE_PATH REL ${CMAKE_CURRENT_SOURCE_DIR}/src ${CMAKE_CURRENT_SOURCE_DIR}/${SRC}) - get_filename_component(DIR ${REL} DIRECTORY) - get_filename_component(BASE ${REL} NAME_WE) - list(APPEND haskell_artifacts dist/build/${DIR}/${BASE}.hi) - endif() -endforeach() - -if(CMAKE_BUILD_TYPE STREQUAL "Debug") - set(hs_optimize -O0) -else() - set(hs_optimize -O1) -endif() - -add_custom_command( - OUTPUT ${haskell_artifacts} - COMMAND ${CABAL} update - # Build dependencies first without --builddir, otherwise it fails. - COMMAND ${CABAL} install --only-dependencies ${hs_enable_test} - COMMAND ${CABAL} configure ${hs_optimize} ${hs_enable_test} --builddir=${CMAKE_CURRENT_BINARY_DIR}/dist - COMMAND ${CABAL} build --builddir=${CMAKE_CURRENT_BINARY_DIR}/dist - COMMAND ${CABAL} install --builddir=${CMAKE_CURRENT_BINARY_DIR}/dist - COMMAND ${CMAKE_COMMAND} -E touch ${CMAKE_CURRENT_BINARY_DIR}/thrift_cabal.stamp - WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} - DEPENDS ${haskell_sources} - COMMENT "Building Haskell library") - -add_custom_target(haskell_library ALL - DEPENDS ${haskell_artifacts}) - -if(BUILD_TESTING) - add_test(NAME HaskellCabalCheck - COMMAND ${CABAL} check - WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) - add_test(NAME HaskellCabalTest - # Cabal fails to find built executable when --builddir is specified. - # So we invoke the executable directly. - # COMMAND ${CABAL} test --builddir=${CMAKE_CURRENT_BINARY_DIR}/dist - # WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) - COMMAND dist/build/spec/spec) -endif() diff --git a/lib/hs/LICENSE b/lib/hs/LICENSE deleted file mode 100644 index d64569567..000000000 --- a/lib/hs/LICENSE +++ /dev/null @@ -1,202 +0,0 @@ - - Apache License - Version 2.0, January 2004 - http://www.apache.org/licenses/ - - TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION - - 1. Definitions. - - "License" shall mean the terms and conditions for use, reproduction, - and distribution as defined by Sections 1 through 9 of this document. - - "Licensor" shall mean the copyright owner or entity authorized by - the copyright owner that is granting the License. - - "Legal Entity" shall mean the union of the acting entity and all - other entities that control, are controlled by, or are under common - control with that entity. For the purposes of this definition, - "control" means (i) the power, direct or indirect, to cause the - direction or management of such entity, whether by contract or - otherwise, or (ii) ownership of fifty percent (50%) or more of the - outstanding shares, or (iii) beneficial ownership of such entity. - - "You" (or "Your") shall mean an individual or Legal Entity - exercising permissions granted by this License. - - "Source" form shall mean the preferred form for making modifications, - including but not limited to software source code, documentation - source, and configuration files. - - "Object" form shall mean any form resulting from mechanical - transformation or translation of a Source form, including but - not limited to compiled object code, generated documentation, - and conversions to other media types. - - "Work" shall mean the work of authorship, whether in Source or - Object form, made available under the License, as indicated by a - copyright notice that is included in or attached to the work - (an example is provided in the Appendix below). - - "Derivative Works" shall mean any work, whether in Source or Object - form, that is based on (or derived from) the Work and for which the - editorial revisions, annotations, elaborations, or other modifications - represent, as a whole, an original work of authorship. For the purposes - of this License, Derivative Works shall not include works that remain - separable from, or merely link (or bind by name) to the interfaces of, - the Work and Derivative Works thereof. - - "Contribution" shall mean any work of authorship, including - the original version of the Work and any modifications or additions - to that Work or Derivative Works thereof, that is intentionally - submitted to Licensor for inclusion in the Work by the copyright owner - or by an individual or Legal Entity authorized to submit on behalf of - the copyright owner. For the purposes of this definition, "submitted" - means any form of electronic, verbal, or written communication sent - to the Licensor or its representatives, including but not limited to - communication on electronic mailing lists, source code control systems, - and issue tracking systems that are managed by, or on behalf of, the - Licensor for the purpose of discussing and improving the Work, but - excluding communication that is conspicuously marked or otherwise - designated in writing by the copyright owner as "Not a Contribution." - - "Contributor" shall mean Licensor and any individual or Legal Entity - on behalf of whom a Contribution has been received by Licensor and - subsequently incorporated within the Work. - - 2. Grant of Copyright License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - copyright license to reproduce, prepare Derivative Works of, - publicly display, publicly perform, sublicense, and distribute the - Work and such Derivative Works in Source or Object form. - - 3. Grant of Patent License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - (except as stated in this section) patent license to make, have made, - use, offer to sell, sell, import, and otherwise transfer the Work, - where such license applies only to those patent claims licensable - by such Contributor that are necessarily infringed by their - Contribution(s) alone or by combination of their Contribution(s) - with the Work to which such Contribution(s) was submitted. If You - institute patent litigation against any entity (including a - cross-claim or counterclaim in a lawsuit) alleging that the Work - or a Contribution incorporated within the Work constitutes direct - or contributory patent infringement, then any patent licenses - granted to You under this License for that Work shall terminate - as of the date such litigation is filed. - - 4. Redistribution. You may reproduce and distribute copies of the - Work or Derivative Works thereof in any medium, with or without - modifications, and in Source or Object form, provided that You - meet the following conditions: - - (a) You must give any other recipients of the Work or - Derivative Works a copy of this License; and - - (b) You must cause any modified files to carry prominent notices - stating that You changed the files; and - - (c) You must retain, in the Source form of any Derivative Works - that You distribute, all copyright, patent, trademark, and - attribution notices from the Source form of the Work, - excluding those notices that do not pertain to any part of - the Derivative Works; and - - (d) If the Work includes a "NOTICE" text file as part of its - distribution, then any Derivative Works that You distribute must - include a readable copy of the attribution notices contained - within such NOTICE file, excluding those notices that do not - pertain to any part of the Derivative Works, in at least one - of the following places: within a NOTICE text file distributed - as part of the Derivative Works; within the Source form or - documentation, if provided along with the Derivative Works; or, - within a display generated by the Derivative Works, if and - wherever such third-party notices normally appear. The contents - of the NOTICE file are for informational purposes only and - do not modify the License. You may add Your own attribution - notices within Derivative Works that You distribute, alongside - or as an addendum to the NOTICE text from the Work, provided - that such additional attribution notices cannot be construed - as modifying the License. - - You may add Your own copyright statement to Your modifications and - may provide additional or different license terms and conditions - for use, reproduction, or distribution of Your modifications, or - for any such Derivative Works as a whole, provided Your use, - reproduction, and distribution of the Work otherwise complies with - the conditions stated in this License. - - 5. Submission of Contributions. Unless You explicitly state otherwise, - any Contribution intentionally submitted for inclusion in the Work - by You to the Licensor shall be under the terms and conditions of - this License, without any additional terms or conditions. - Notwithstanding the above, nothing herein shall supersede or modify - the terms of any separate license agreement you may have executed - with Licensor regarding such Contributions. - - 6. Trademarks. This License does not grant permission to use the trade - names, trademarks, service marks, or product names of the Licensor, - except as required for reasonable and customary use in describing the - origin of the Work and reproducing the content of the NOTICE file. - - 7. Disclaimer of Warranty. Unless required by applicable law or - agreed to in writing, Licensor provides the Work (and each - Contributor provides its Contributions) on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or - implied, including, without limitation, any warranties or conditions - of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A - PARTICULAR PURPOSE. You are solely responsible for determining the - appropriateness of using or redistributing the Work and assume any - risks associated with Your exercise of permissions under this License. - - 8. Limitation of Liability. In no event and under no legal theory, - whether in tort (including negligence), contract, or otherwise, - unless required by applicable law (such as deliberate and grossly - negligent acts) or agreed to in writing, shall any Contributor be - liable to You for damages, including any direct, indirect, special, - incidental, or consequential damages of any character arising as a - result of this License or out of the use or inability to use the - Work (including but not limited to damages for loss of goodwill, - work stoppage, computer failure or malfunction, or any and all - other commercial damages or losses), even if such Contributor - has been advised of the possibility of such damages. - - 9. Accepting Warranty or Additional Liability. While redistributing - the Work or Derivative Works thereof, You may choose to offer, - and charge a fee for, acceptance of support, warranty, indemnity, - or other liability obligations and/or rights consistent with this - License. However, in accepting such obligations, You may act only - on Your own behalf and on Your sole responsibility, not on behalf - of any other Contributor, and only if You agree to indemnify, - defend, and hold each Contributor harmless for any liability - incurred by, or claims asserted against, such Contributor by reason - of your accepting any such warranty or additional liability. - - END OF TERMS AND CONDITIONS - - APPENDIX: How to apply the Apache License to your work. - - To apply the Apache License to your work, attach the following - boilerplate notice, with the fields enclosed by brackets "[]" - replaced with your own identifying information. (Don't include - the brackets!) The text should be enclosed in the appropriate - comment syntax for the file format. We also recommend that a - file or class name and description of purpose be included on the - same "printed page" as the copyright notice for easier - identification within third-party archives. - - Copyright [yyyy] [name of copyright owner] - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. diff --git a/lib/hs/Makefile.am b/lib/hs/Makefile.am deleted file mode 100644 index ba156a130..000000000 --- a/lib/hs/Makefile.am +++ /dev/null @@ -1,53 +0,0 @@ -# -# Licensed to the Apache Software Foundation (ASF) under one -# or more contributor license agreements. See the NOTICE file -# distributed with this work for additional information -# regarding copyright ownership. The ASF licenses this file -# to you under the Apache License, Version 2.0 (the -# "License"); you may not use this file except in compliance -# with the License. You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, -# software distributed under the License is distributed on an -# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -# KIND, either express or implied. See the License for the -# specific language governing permissions and limitations -# under the License. -# - -EXTRA_DIST = \ - coding_standards.md \ - CMakeLists.txt \ - LICENSE \ - README.md \ - Setup.lhs \ - TODO \ - thrift.cabal \ - src \ - test - -all-local: - $(CABAL) update - $(CABAL) install - -install-exec-hook: - $(CABAL) install - -# Make sure this doesn't fail if Haskell is not configured. -clean-local: - $(CABAL) clean - -dist-local: - $(CABAL) sdist - -maintainer-clean-local: - $(CABAL) clean - -check-local: - $(CABAL) check - $(CABAL) install --only-dependencies --enable-tests - $(CABAL) configure --enable-tests - $(CABAL) build - $(CABAL) test diff --git a/lib/hs/README.md b/lib/hs/README.md deleted file mode 100644 index 10bdeff1e..000000000 --- a/lib/hs/README.md +++ /dev/null @@ -1,113 +0,0 @@ -Haskell Thrift Bindings - -License -======= - -Licensed to the Apache Software Foundation (ASF) under one -or more contributor license agreements. See the NOTICE file -distributed with this work for additional information -regarding copyright ownership. The ASF licenses this file -to you under the Apache License, Version 2.0 (the -"License"); you may not use this file except in compliance -with the License. You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - -Unless required by applicable law or agreed to in writing, -software distributed under the License is distributed on an -"AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -KIND, either express or implied. See the License for the -specific language governing permissions and limitations -under the License. - -Compile -======= - -Use Cabal to compile and install; ./configure uses Cabal underneath, and that -path is not yet well tested. Thrift's library and generated code should compile -with pretty much any GHC extensions or warnings you enable (or disable). -Please report this not being the case as a bug on -https://issues.apache.org/jira/secure/CreateIssue!default.jspa - -Chances you'll need to muck a bit with Cabal flags to install Thrift: - -CABAL_CONFIGURE_FLAGS="--user" ./configure - -Base Types -========== - -The mapping from Thrift types to Haskell's is: - - * double -> Double - * byte -> Data.Int.Int8 - * i16 -> Data.Int.Int16 - * i32 -> Data.Int.Int32 - * i64 -> Data.Int.Int64 - * string -> Text - * binary -> Data.ByteString.Lazy - * bool -> Boolean - -Enums -===== - -Become Haskell 'data' types. Use fromEnum to get out the int value. - -Lists -===== - -Become Data.Vector.Vector from the vector package. - -Maps and Sets -============= - -Become Data.HashMap.Strict.Map and Data.HashSet.Set from the -unordered-containers package. - -Structs -======= - -Become records. Field labels are ugly, of the form f_STRUCTNAME_FIELDNAME. All -fields are Maybe types. - -Exceptions -========== - -Identical to structs. Use them with throw and catch from Control.Exception. - -Client -====== - -Just a bunch of functions. You may have to import a bunch of client files to -deal with inheritance. - -Interface -========= - -You should only have to import the last one in the chain of inheritors. To make -an interface, declare a label: - - data MyIface = MyIface - -and then declare it an instance of each iface class, starting with the superest -class and proceeding down (all the while defining the methods). Then pass your -label to process as the handler. - -Processor -========= - -Just a function that takes a handler label, protocols. It calls the -superclasses process if there is a superclass. - -Releasing to Hackage -==================== - -Using the [Docker Container for Ubuntu Bionic](../../build/docker/README.md), run: - - root@e941f5311545:/thrift/src# ./bootstrap.sh && ./configure - root@e941f5311545:/thrift/src# cd lib/hs && make dist-local - -This will produce a `lib/hs/dist/thrift-<version>.tar.gz` file. Take this -file and upload it as a Haskell Hackage -[package candidate](https://hackage.haskell.org/upload#candidates) and -check to make sure all the information is correct. Assuming all is satisfactory, -you can upload the package as official using the link at the top of the page. diff --git a/lib/hs/Setup.lhs b/lib/hs/Setup.lhs deleted file mode 100755 index d52ae9455..000000000 --- a/lib/hs/Setup.lhs +++ /dev/null @@ -1,21 +0,0 @@ -#!/usr/bin/env runhaskell - -> -- Licensed to the Apache Software Foundation (ASF) under one -> -- or more contributor license agreements. See the NOTICE file -> -- distributed with this work for additional information -> -- regarding copyright ownership. The ASF licenses this file -> -- to you under the Apache License, Version 2.0 (the -> -- "License"); you may not use this file except in compliance -> -- with the License. You may obtain a copy of the License at -> -- -> -- http://www.apache.org/licenses/LICENSE-2.0 -> -- -> -- Unless required by applicable law or agreed to in writing, -> -- software distributed under the License is distributed on an -> -- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -> -- KIND, either express or implied. See the License for the -> -- specific language governing permissions and limitations -> -- under the License. - -> import Distribution.Simple -> main = defaultMain diff --git a/lib/hs/TODO b/lib/hs/TODO deleted file mode 100644 index 136817321..000000000 --- a/lib/hs/TODO +++ /dev/null @@ -1,2 +0,0 @@ -The library could stand to be built up more. -Many modules need export lists. diff --git a/lib/hs/coding_standards.md b/lib/hs/coding_standards.md deleted file mode 100644 index fa0390bb5..000000000 --- a/lib/hs/coding_standards.md +++ /dev/null @@ -1 +0,0 @@ -Please follow [General Coding Standards](/doc/coding_standards.md) diff --git a/lib/hs/src/Thrift.hs b/lib/hs/src/Thrift.hs deleted file mode 100644 index 658020991..000000000 --- a/lib/hs/src/Thrift.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -module Thrift - ( module Thrift.Transport - , module Thrift.Protocol - , AppExnType(..) - , AppExn(..) - , readAppExn - , writeAppExn - , ThriftException(..) - ) where - -import Control.Exception - -import Data.Int -import Data.Text.Lazy ( Text, pack, unpack ) -import Data.Text.Lazy.Encoding -import Data.Typeable ( Typeable ) -import qualified Data.HashMap.Strict as Map - -import Thrift.Protocol -import Thrift.Transport -import Thrift.Types - -data ThriftException = ThriftException - deriving ( Show, Typeable ) -instance Exception ThriftException - -data AppExnType - = AE_UNKNOWN - | AE_UNKNOWN_METHOD - | AE_INVALID_MESSAGE_TYPE - | AE_WRONG_METHOD_NAME - | AE_BAD_SEQUENCE_ID - | AE_MISSING_RESULT - | AE_INTERNAL_ERROR - | AE_PROTOCOL_ERROR - | AE_INVALID_TRANSFORM - | AE_INVALID_PROTOCOL - | AE_UNSUPPORTED_CLIENT_TYPE - deriving ( Eq, Show, Typeable ) - -instance Enum AppExnType where - toEnum 0 = AE_UNKNOWN - toEnum 1 = AE_UNKNOWN_METHOD - toEnum 2 = AE_INVALID_MESSAGE_TYPE - toEnum 3 = AE_WRONG_METHOD_NAME - toEnum 4 = AE_BAD_SEQUENCE_ID - toEnum 5 = AE_MISSING_RESULT - toEnum 6 = AE_INTERNAL_ERROR - toEnum 7 = AE_PROTOCOL_ERROR - toEnum 8 = AE_INVALID_TRANSFORM - toEnum 9 = AE_INVALID_PROTOCOL - toEnum 10 = AE_UNSUPPORTED_CLIENT_TYPE - toEnum t = error $ "Invalid AppExnType " ++ show t - - fromEnum AE_UNKNOWN = 0 - fromEnum AE_UNKNOWN_METHOD = 1 - fromEnum AE_INVALID_MESSAGE_TYPE = 2 - fromEnum AE_WRONG_METHOD_NAME = 3 - fromEnum AE_BAD_SEQUENCE_ID = 4 - fromEnum AE_MISSING_RESULT = 5 - fromEnum AE_INTERNAL_ERROR = 6 - fromEnum AE_PROTOCOL_ERROR = 7 - fromEnum AE_INVALID_TRANSFORM = 8 - fromEnum AE_INVALID_PROTOCOL = 9 - fromEnum AE_UNSUPPORTED_CLIENT_TYPE = 10 - -data AppExn = AppExn { ae_type :: AppExnType, ae_message :: String } - deriving ( Show, Typeable ) -instance Exception AppExn - -writeAppExn :: Protocol p => p -> AppExn -> IO () -writeAppExn pt ae = writeVal pt $ TStruct $ Map.fromList - [ (1, ("message", TString $ encodeUtf8 $ pack $ ae_message ae)) - , (2, ("type", TI32 $ fromIntegral $ fromEnum (ae_type ae))) - ] - -readAppExn :: Protocol p => p -> IO AppExn -readAppExn pt = do - let typemap = Map.fromList [(1,("message",T_STRING)),(2,("type",T_I32))] - TStruct fields <- readVal pt $ T_STRUCT typemap - return $ readAppExnFields fields - -readAppExnFields :: Map.HashMap Int16 (Text, ThriftVal) -> AppExn -readAppExnFields fields = AppExn{ - ae_message = maybe undefined unwrapMessage $ Map.lookup 1 fields, - ae_type = maybe undefined unwrapType $ Map.lookup 2 fields - } - where - unwrapMessage (_, TString s) = unpack $ decodeUtf8 s - unwrapMessage _ = undefined - unwrapType (_, TI32 i) = toEnum $ fromIntegral i - unwrapType _ = undefined diff --git a/lib/hs/src/Thrift/Arbitraries.hs b/lib/hs/src/Thrift/Arbitraries.hs deleted file mode 100644 index e9c0fc3ee..000000000 --- a/lib/hs/src/Thrift/Arbitraries.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Thrift.Arbitraries where - -import Data.Bits() - -import Test.QuickCheck.Arbitrary - -import Control.Applicative ((<$>)) -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Vector as Vector -import qualified Data.Text.Lazy as Text -import qualified Data.HashSet as HSet -import qualified Data.HashMap.Strict as HMap -import Data.Hashable (Hashable) - -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as BS - --- String has an Arbitrary instance already --- Bool has an Arbitrary instance already --- A Thrift 'list' is a Vector. - -instance Arbitrary ByteString where - arbitrary = BS.pack . filter (/= 0) <$> arbitrary - -instance (Arbitrary k) => Arbitrary (Vector.Vector k) where - arbitrary = Vector.fromList <$> arbitrary - -instance Arbitrary Text.Text where - arbitrary = Text.pack . filter (/= '\0') <$> arbitrary - -instance (Eq k, Hashable k, Arbitrary k) => Arbitrary (HSet.HashSet k) where - arbitrary = HSet.fromList <$> arbitrary - -instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => - Arbitrary (HMap.HashMap k v) where - arbitrary = HMap.fromList <$> arbitrary - -{- - To handle Thrift 'enum' we would ideally use something like: - -instance (Enum a, Bounded a) => Arbitrary a - where arbitrary = elements (enumFromTo minBound maxBound) - -Unfortunately this doesn't play nicely with the type system. -Instead we'll generate an arbitrary instance along with the code. --} - -{- - There might be some way to introspect on the Haskell structure of a - Thrift 'struct' or 'exception' but generating the code directly is simpler. --} diff --git a/lib/hs/src/Thrift/Protocol.hs b/lib/hs/src/Thrift/Protocol.hs deleted file mode 100644 index 67a9175cb..000000000 --- a/lib/hs/src/Thrift/Protocol.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -module Thrift.Protocol - ( Protocol(..) - , StatelessProtocol(..) - , ProtocolExn(..) - , ProtocolExnType(..) - , getTypeOf - , runParser - , bsToDouble - , bsToDoubleLE - ) where - -import Control.Exception -import Data.Attoparsec.ByteString -import Data.Bits -import Data.ByteString.Unsafe -import Data.Functor ((<$>)) -import Data.Int -import Data.Monoid (mempty) -import Data.Text.Lazy (Text) -import Data.Typeable (Typeable) -import Data.Word -import Foreign.Ptr (castPtr) -import Foreign.Storable (peek, poke) -import System.IO.Unsafe -import qualified Data.ByteString as BS -import qualified Data.HashMap.Strict as Map -import qualified Data.ByteString.Lazy as LBS - -import Thrift.Transport -import Thrift.Types - -class Protocol a where - readByte :: a -> IO LBS.ByteString - readVal :: a -> ThriftType -> IO ThriftVal - readMessage :: a -> ((Text, MessageType, Int32) -> IO b) -> IO b - - writeVal :: a -> ThriftVal -> IO () - writeMessage :: a -> (Text, MessageType, Int32) -> IO () -> IO () - -class Protocol a => StatelessProtocol a where - serializeVal :: a -> ThriftVal -> LBS.ByteString - deserializeVal :: a -> ThriftType -> LBS.ByteString -> ThriftVal - -data ProtocolExnType - = PE_UNKNOWN - | PE_INVALID_DATA - | PE_NEGATIVE_SIZE - | PE_SIZE_LIMIT - | PE_BAD_VERSION - | PE_NOT_IMPLEMENTED - | PE_MISSING_REQUIRED_FIELD - deriving ( Eq, Show, Typeable ) - -data ProtocolExn = ProtocolExn ProtocolExnType String - deriving ( Show, Typeable ) -instance Exception ProtocolExn - -getTypeOf :: ThriftVal -> ThriftType -getTypeOf v = case v of - TStruct{} -> T_STRUCT Map.empty - TMap{} -> T_MAP T_VOID T_VOID - TList{} -> T_LIST T_VOID - TSet{} -> T_SET T_VOID - TBool{} -> T_BOOL - TByte{} -> T_BYTE - TI16{} -> T_I16 - TI32{} -> T_I32 - TI64{} -> T_I64 - TString{} -> T_STRING - TBinary{} -> T_BINARY - TDouble{} -> T_DOUBLE - -runParser :: (Protocol p, Show a) => p -> Parser a -> IO a -runParser prot p = refill >>= getResult . parse p - where - refill = handle handleEOF $ LBS.toStrict <$> readByte prot - getResult (Done _ a) = return a - getResult (Partial k) = refill >>= getResult . k - getResult f = throw $ ProtocolExn PE_INVALID_DATA (show f) - -handleEOF :: SomeException -> IO BS.ByteString -handleEOF = const $ return mempty - --- | Converts a ByteString to a Floating point number --- The ByteString is assumed to be encoded in network order (Big Endian) --- therefore the behavior of this function varies based on whether the local --- machine is big endian or little endian. -bsToDouble :: BS.ByteString -> Double -bsToDoubleLE :: BS.ByteString -> Double -#if __BYTE_ORDER == __LITTLE_ENDIAN -bsToDouble bs = unsafeDupablePerformIO $ unsafeUseAsCString bs castBsSwapped -bsToDoubleLE bs = unsafeDupablePerformIO $ unsafeUseAsCString bs castBs -#else -bsToDouble bs = unsafeDupablePerformIO $ unsafeUseAsCString bs castBs -bsToDoubleLE bs = unsafeDupablePerformIO $ unsafeUseAsCString bs castBsSwapped -#endif - - -castBsSwapped chrPtr = do - w <- peek (castPtr chrPtr) - poke (castPtr chrPtr) (byteSwap w) - peek (castPtr chrPtr) -castBs = peek . castPtr - --- | Swap endianness of a 64-bit word -byteSwap :: Word64 -> Word64 -byteSwap w = (w `shiftL` 56 .&. 0xFF00000000000000) .|. - (w `shiftL` 40 .&. 0x00FF000000000000) .|. - (w `shiftL` 24 .&. 0x0000FF0000000000) .|. - (w `shiftL` 8 .&. 0x000000FF00000000) .|. - (w `shiftR` 8 .&. 0x00000000FF000000) .|. - (w `shiftR` 24 .&. 0x0000000000FF0000) .|. - (w `shiftR` 40 .&. 0x000000000000FF00) .|. - (w `shiftR` 56 .&. 0x00000000000000FF) diff --git a/lib/hs/src/Thrift/Protocol/Binary.hs b/lib/hs/src/Thrift/Protocol/Binary.hs deleted file mode 100644 index 7b0acd9d4..000000000 --- a/lib/hs/src/Thrift/Protocol/Binary.hs +++ /dev/null @@ -1,212 +0,0 @@ --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Thrift.Protocol.Binary - ( module Thrift.Protocol - , BinaryProtocol(..) - , versionMask - , version1 - ) where - -import Control.Exception ( throw ) -import Control.Monad -import Data.Bits -import Data.ByteString.Lazy.Builder -import Data.Functor -import Data.Int -import Data.Monoid -import Data.Text.Lazy.Encoding ( decodeUtf8, encodeUtf8 ) -import Data.Word - -import Thrift.Protocol -import Thrift.Transport -import Thrift.Types - -import qualified Data.Attoparsec.ByteString as P -import qualified Data.Attoparsec.ByteString.Lazy as LP -import qualified Data.Binary as Binary -import qualified Data.ByteString.Lazy as LBS -import qualified Data.HashMap.Strict as Map -import qualified Data.Text.Lazy as LT - -versionMask :: Int32 -versionMask = fromIntegral (0xffff0000 :: Word32) - -version1 :: Int32 -version1 = fromIntegral (0x80010000 :: Word32) - -data BinaryProtocol a = Transport a => BinaryProtocol a - -getTransport :: Transport t => BinaryProtocol t -> t -getTransport (BinaryProtocol t) = t - --- NOTE: Reading and Writing functions rely on Builders and Data.Binary to --- encode and decode data. Data.Binary assumes that the binary values it is --- encoding to and decoding from are in BIG ENDIAN format, and converts the --- endianness as necessary to match the local machine. -instance Transport t => Protocol (BinaryProtocol t) where - readByte p = tReadAll (getTransport p) 1 - -- flushTransport p = tFlush (getTransport p) - writeMessage p (n, t, s) f = do - tWrite (getTransport p) messageBegin - f - tFlush $ getTransport p - where - messageBegin = toLazyByteString $ - buildBinaryValue (TI32 (version1 .|. fromIntegral (fromEnum t))) <> - buildBinaryValue (TString $ encodeUtf8 n) <> - buildBinaryValue (TI32 s) - - readMessage p = (readMessageBegin p >>=) - where - readMessageBegin p = runParser p $ do - TI32 ver <- parseBinaryValue T_I32 - if ver .&. versionMask /= version1 - then throw $ ProtocolExn PE_BAD_VERSION "Missing version identifier" - else do - TString s <- parseBinaryValue T_STRING - TI32 sz <- parseBinaryValue T_I32 - return (decodeUtf8 s, toEnum $ fromIntegral $ ver .&. 0xFF, sz) - - writeVal p = tWrite (getTransport p) . toLazyByteString . buildBinaryValue - readVal p = runParser p . parseBinaryValue - -instance Transport t => StatelessProtocol (BinaryProtocol t) where - serializeVal _ = toLazyByteString . buildBinaryValue - deserializeVal _ ty bs = - case LP.eitherResult $ LP.parse (parseBinaryValue ty) bs of - Left s -> error s - Right val -> val - --- | Writing Functions -buildBinaryValue :: ThriftVal -> Builder -buildBinaryValue (TStruct fields) = buildBinaryStruct fields <> buildType T_STOP -buildBinaryValue (TMap ky vt entries) = - buildType ky <> - buildType vt <> - int32BE (fromIntegral (length entries)) <> - buildBinaryMap entries -buildBinaryValue (TList ty entries) = - buildType ty <> - int32BE (fromIntegral (length entries)) <> - buildBinaryList entries -buildBinaryValue (TSet ty entries) = - buildType ty <> - int32BE (fromIntegral (length entries)) <> - buildBinaryList entries -buildBinaryValue (TBool b) = - word8 $ toEnum $ if b then 1 else 0 -buildBinaryValue (TByte b) = int8 b -buildBinaryValue (TI16 i) = int16BE i -buildBinaryValue (TI32 i) = int32BE i -buildBinaryValue (TI64 i) = int64BE i -buildBinaryValue (TDouble d) = doubleBE d -buildBinaryValue (TString s) = int32BE len <> lazyByteString s - where - len :: Int32 = fromIntegral (LBS.length s) -buildBinaryValue (TBinary s) = buildBinaryValue (TString s) - -buildBinaryStruct :: Map.HashMap Int16 (LT.Text, ThriftVal) -> Builder -buildBinaryStruct = Map.foldrWithKey combine mempty - where - combine fid (_,val) s = - buildTypeOf val <> int16BE fid <> buildBinaryValue val <> s - -buildBinaryMap :: [(ThriftVal, ThriftVal)] -> Builder -buildBinaryMap = foldl combine mempty - where - combine s (key, val) = s <> buildBinaryValue key <> buildBinaryValue val - -buildBinaryList :: [ThriftVal] -> Builder -buildBinaryList = foldr (mappend . buildBinaryValue) mempty - --- | Reading Functions -parseBinaryValue :: ThriftType -> P.Parser ThriftVal -parseBinaryValue (T_STRUCT tmap) = TStruct <$> parseBinaryStruct tmap -parseBinaryValue (T_MAP _ _) = do - kt <- parseType - vt <- parseType - n <- Binary.decode . LBS.fromStrict <$> P.take 4 - TMap kt vt <$> parseBinaryMap kt vt n -parseBinaryValue (T_LIST _) = do - t <- parseType - n <- Binary.decode . LBS.fromStrict <$> P.take 4 - TList t <$> parseBinaryList t n -parseBinaryValue (T_SET _) = do - t <- parseType - n <- Binary.decode . LBS.fromStrict <$> P.take 4 - TSet t <$> parseBinaryList t n -parseBinaryValue T_BOOL = TBool . (/=0) <$> P.anyWord8 -parseBinaryValue T_BYTE = TByte . Binary.decode . LBS.fromStrict <$> P.take 1 -parseBinaryValue T_I16 = TI16 . Binary.decode . LBS.fromStrict <$> P.take 2 -parseBinaryValue T_I32 = TI32 . Binary.decode . LBS.fromStrict <$> P.take 4 -parseBinaryValue T_I64 = TI64 . Binary.decode . LBS.fromStrict <$> P.take 8 -parseBinaryValue T_DOUBLE = TDouble . bsToDouble <$> P.take 8 -parseBinaryValue T_STRING = parseBinaryString TString -parseBinaryValue T_BINARY = parseBinaryString TBinary -parseBinaryValue ty = error $ "Cannot read value of type " ++ show ty - -parseBinaryString ty = do - i :: Int32 <- Binary.decode . LBS.fromStrict <$> P.take 4 - ty . LBS.fromStrict <$> P.take (fromIntegral i) - -parseBinaryStruct :: TypeMap -> P.Parser (Map.HashMap Int16 (LT.Text, ThriftVal)) -parseBinaryStruct tmap = Map.fromList <$> P.manyTill parseField (matchType T_STOP) - where - parseField = do - t <- parseType - n <- Binary.decode . LBS.fromStrict <$> P.take 2 - v <- case (t, Map.lookup n tmap) of - (T_STRING, Just (_, T_BINARY)) -> parseBinaryValue T_BINARY - _ -> parseBinaryValue t - return (n, ("", v)) - -parseBinaryMap :: ThriftType -> ThriftType -> Int32 -> P.Parser [(ThriftVal, ThriftVal)] -parseBinaryMap kt vt n | n <= 0 = return [] - | otherwise = do - k <- parseBinaryValue kt - v <- parseBinaryValue vt - ((k,v) :) <$> parseBinaryMap kt vt (n-1) - -parseBinaryList :: ThriftType -> Int32 -> P.Parser [ThriftVal] -parseBinaryList ty n | n <= 0 = return [] - | otherwise = liftM2 (:) (parseBinaryValue ty) - (parseBinaryList ty (n-1)) - - - --- | Write a type as a byte -buildType :: ThriftType -> Builder -buildType t = word8 $ fromIntegral $ fromEnum t - --- | Write type of a ThriftVal as a byte -buildTypeOf :: ThriftVal -> Builder -buildTypeOf = buildType . getTypeOf - --- | Read a byte as though it were a ThriftType -parseType :: P.Parser ThriftType -parseType = toEnum . fromIntegral <$> P.anyWord8 - -matchType :: ThriftType -> P.Parser ThriftType -matchType t = t <$ P.word8 (fromIntegral $ fromEnum t) diff --git a/lib/hs/src/Thrift/Protocol/Compact.hs b/lib/hs/src/Thrift/Protocol/Compact.hs deleted file mode 100644 index f23970a82..000000000 --- a/lib/hs/src/Thrift/Protocol/Compact.hs +++ /dev/null @@ -1,311 +0,0 @@ --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Thrift.Protocol.Compact - ( module Thrift.Protocol - , CompactProtocol(..) - , parseVarint - , buildVarint - ) where - -import Control.Applicative -import Control.Monad -import Data.Attoparsec.ByteString as P -import Data.Attoparsec.ByteString.Lazy as LP -import Data.Bits -import Data.ByteString.Lazy.Builder as B -import Data.Int -import Data.List as List -import Data.Monoid -import Data.Word -import Data.Text.Lazy.Encoding ( decodeUtf8, encodeUtf8 ) - -import Thrift.Protocol -import Thrift.Transport -import Thrift.Types - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.HashMap.Strict as Map -import qualified Data.Text.Lazy as LT - --- | the Compact Protocol implements the standard Thrift 'TCompactProcotol' --- which is similar to the 'TBinaryProtocol', but takes less space on the wire. --- Integral types are encoded using as varints. -data CompactProtocol a = CompactProtocol a - -- ^ Constuct a 'CompactProtocol' with a 'Transport' - -protocolID, version, versionMask, typeMask, typeBits :: Word8 -protocolID = 0x82 -- 1000 0010 -version = 0x01 -versionMask = 0x1f -- 0001 1111 -typeMask = 0xe0 -- 1110 0000 -typeBits = 0x07 -- 0000 0111 -typeShiftAmount :: Int -typeShiftAmount = 5 - -getTransport :: Transport t => CompactProtocol t -> t -getTransport (CompactProtocol t) = t - -instance Transport t => Protocol (CompactProtocol t) where - readByte p = tReadAll (getTransport p) 1 - writeMessage p (n, t, s) f = do - tWrite (getTransport p) messageBegin - f - tFlush $ getTransport p - where - messageBegin = toLazyByteString $ - B.word8 protocolID <> - B.word8 ((version .&. versionMask) .|. - (((fromIntegral $ fromEnum t) `shiftL` - typeShiftAmount) .&. typeMask)) <> - buildVarint (i32ToZigZag s) <> - buildCompactValue (TString $ encodeUtf8 n) - - readMessage p f = readMessageBegin >>= f - where - readMessageBegin = runParser p $ do - pid <- fromIntegral <$> P.anyWord8 - when (pid /= protocolID) $ error "Bad Protocol ID" - w <- fromIntegral <$> P.anyWord8 - let ver = w .&. versionMask - when (ver /= version) $ error "Bad Protocol version" - let typ = (w `shiftR` typeShiftAmount) .&. typeBits - seqId <- parseVarint zigZagToI32 - TString name <- parseCompactValue T_STRING - return (decodeUtf8 name, toEnum $ fromIntegral $ typ, seqId) - - writeVal p = tWrite (getTransport p) . toLazyByteString . buildCompactValue - readVal p ty = runParser p $ parseCompactValue ty - -instance Transport t => StatelessProtocol (CompactProtocol t) where - serializeVal _ = toLazyByteString . buildCompactValue - deserializeVal _ ty bs = - case LP.eitherResult $ LP.parse (parseCompactValue ty) bs of - Left s -> error s - Right val -> val - --- | Writing Functions -buildCompactValue :: ThriftVal -> Builder -buildCompactValue (TStruct fields) = buildCompactStruct fields -buildCompactValue (TMap kt vt entries) = - let len = fromIntegral $ length entries :: Word32 in - if len == 0 - then B.word8 0x00 - else buildVarint len <> - B.word8 (fromTType kt `shiftL` 4 .|. fromTType vt) <> - buildCompactMap entries -buildCompactValue (TList ty entries) = - let len = length entries in - (if len < 15 - then B.word8 $ (fromIntegral len `shiftL` 4) .|. fromTType ty - else B.word8 (0xF0 .|. fromTType ty) <> - buildVarint (fromIntegral len :: Word32)) <> - buildCompactList entries -buildCompactValue (TSet ty entries) = buildCompactValue (TList ty entries) -buildCompactValue (TBool b) = - B.word8 $ toEnum $ if b then 1 else 0 -buildCompactValue (TByte b) = int8 b -buildCompactValue (TI16 i) = buildVarint $ i16ToZigZag i -buildCompactValue (TI32 i) = buildVarint $ i32ToZigZag i -buildCompactValue (TI64 i) = buildVarint $ i64ToZigZag i -buildCompactValue (TDouble d) = doubleLE d -buildCompactValue (TString s) = buildVarint len <> lazyByteString s - where - len = fromIntegral (LBS.length s) :: Word32 -buildCompactValue (TBinary s) = buildCompactValue (TString s) - -buildCompactStruct :: Map.HashMap Int16 (LT.Text, ThriftVal) -> Builder -buildCompactStruct = flip (loop 0) mempty . Map.toList - where - loop _ [] acc = acc <> B.word8 (fromTType T_STOP) - loop lastId ((fid, (_,val)) : fields) acc = loop fid fields $ acc <> - (if fid > lastId && fid - lastId <= 15 - then B.word8 $ fromIntegral ((fid - lastId) `shiftL` 4) .|. typeOf val - else B.word8 (typeOf val) <> buildVarint (i16ToZigZag fid)) <> - (if typeOf val > 0x02 -- Not a T_BOOL - then buildCompactValue val - else mempty) -- T_BOOLs are encoded in the type -buildCompactMap :: [(ThriftVal, ThriftVal)] -> Builder -buildCompactMap = foldl combine mempty - where - combine s (key, val) = buildCompactValue key <> buildCompactValue val <> s - -buildCompactList :: [ThriftVal] -> Builder -buildCompactList = foldr (mappend . buildCompactValue) mempty - --- | Reading Functions -parseCompactValue :: ThriftType -> Parser ThriftVal -parseCompactValue (T_STRUCT tmap) = TStruct <$> parseCompactStruct tmap -parseCompactValue (T_MAP kt' vt') = do - n <- parseVarint id - if n == 0 - then return $ TMap kt' vt' [] - else do - w <- P.anyWord8 - let kt = typeFrom $ w `shiftR` 4 - vt = typeFrom $ w .&. 0x0F - TMap kt vt <$> parseCompactMap kt vt n -parseCompactValue (T_LIST ty) = TList ty <$> parseCompactList -parseCompactValue (T_SET ty) = TSet ty <$> parseCompactList -parseCompactValue T_BOOL = TBool . (/=0) <$> P.anyWord8 -parseCompactValue T_BYTE = TByte . fromIntegral <$> P.anyWord8 -parseCompactValue T_I16 = TI16 <$> parseVarint zigZagToI16 -parseCompactValue T_I32 = TI32 <$> parseVarint zigZagToI32 -parseCompactValue T_I64 = TI64 <$> parseVarint zigZagToI64 -parseCompactValue T_DOUBLE = TDouble . bsToDoubleLE <$> P.take 8 -parseCompactValue T_STRING = parseCompactString TString -parseCompactValue T_BINARY = parseCompactString TBinary -parseCompactValue ty = error $ "Cannot read value of type " ++ show ty - -parseCompactString ty = do - len :: Word32 <- parseVarint id - ty . LBS.fromStrict <$> P.take (fromIntegral len) - -parseCompactStruct :: TypeMap -> Parser (Map.HashMap Int16 (LT.Text, ThriftVal)) -parseCompactStruct tmap = Map.fromList <$> parseFields 0 - where - parseFields :: Int16 -> Parser [(Int16, (LT.Text, ThriftVal))] - parseFields lastId = do - w <- P.anyWord8 - if w == 0x00 - then return [] - else do - let ty = typeFrom (w .&. 0x0F) - modifier = (w .&. 0xF0) `shiftR` 4 - fid <- if modifier /= 0 - then return (lastId + fromIntegral modifier) - else parseVarint zigZagToI16 - val <- if ty == T_BOOL - then return (TBool $ (w .&. 0x0F) == 0x01) - else case (ty, Map.lookup fid tmap) of - (T_STRING, Just (_, T_BINARY)) -> parseCompactValue T_BINARY - _ -> parseCompactValue ty - ((fid, (LT.empty, val)) : ) <$> parseFields fid - -parseCompactMap :: ThriftType -> ThriftType -> Int32 -> - Parser [(ThriftVal, ThriftVal)] -parseCompactMap kt vt n | n <= 0 = return [] - | otherwise = do - k <- parseCompactValue kt - v <- parseCompactValue vt - ((k,v) :) <$> parseCompactMap kt vt (n-1) - -parseCompactList :: Parser [ThriftVal] -parseCompactList = do - w <- P.anyWord8 - let ty = typeFrom $ w .&. 0x0F - lsize = w `shiftR` 4 - size <- if lsize == 0xF - then parseVarint id - else return $ fromIntegral lsize - loop ty size - where - loop :: ThriftType -> Int32 -> Parser [ThriftVal] - loop ty n | n <= 0 = return [] - | otherwise = liftM2 (:) (parseCompactValue ty) - (loop ty (n-1)) - --- Signed numbers must be converted to "Zig Zag" format before they can be --- serialized in the Varint format -i16ToZigZag :: Int16 -> Word16 -i16ToZigZag n = fromIntegral $ (n `shiftL` 1) `xor` (n `shiftR` 15) - -zigZagToI16 :: Word16 -> Int16 -zigZagToI16 n = fromIntegral $ (n `shiftR` 1) `xor` negate (n .&. 0x1) - -i32ToZigZag :: Int32 -> Word32 -i32ToZigZag n = fromIntegral $ (n `shiftL` 1) `xor` (n `shiftR` 31) - -zigZagToI32 :: Word32 -> Int32 -zigZagToI32 n = fromIntegral $ (n `shiftR` 1) `xor` negate (n .&. 0x1) - -i64ToZigZag :: Int64 -> Word64 -i64ToZigZag n = fromIntegral $ (n `shiftL` 1) `xor` (n `shiftR` 63) - -zigZagToI64 :: Word64 -> Int64 -zigZagToI64 n = fromIntegral $ (n `shiftR` 1) `xor` negate (n .&. 0x1) - -buildVarint :: (Bits a, Integral a) => a -> Builder -buildVarint n | n .&. complement 0x7F == 0 = B.word8 $ fromIntegral n - | otherwise = B.word8 (0x80 .|. (fromIntegral n .&. 0x7F)) <> - buildVarint (n `shiftR` 7) - -parseVarint :: (Bits a, Integral a, Ord a) => (a -> b) -> Parser b -parseVarint fromZigZag = do - bytestemp <- BS.unpack <$> P.takeTill (not . flip testBit 7) - lsb <- P.anyWord8 - let bytes = lsb : List.reverse bytestemp - return $ fromZigZag $ List.foldl' combine 0x00 bytes - where combine a b = (a `shiftL` 7) .|. (fromIntegral b .&. 0x7f) - --- | Compute the Compact Type -fromTType :: ThriftType -> Word8 -fromTType ty = case ty of - T_STOP -> 0x00 - T_BOOL -> 0x01 - T_BYTE -> 0x03 - T_I16 -> 0x04 - T_I32 -> 0x05 - T_I64 -> 0x06 - T_DOUBLE -> 0x07 - T_STRING -> 0x08 - T_BINARY -> 0x08 - T_LIST{} -> 0x09 - T_SET{} -> 0x0A - T_MAP{} -> 0x0B - T_STRUCT{} -> 0x0C - T_VOID -> error "No Compact type for T_VOID" - -typeOf :: ThriftVal -> Word8 -typeOf v = case v of - TBool True -> 0x01 - TBool False -> 0x02 - TByte _ -> 0x03 - TI16 _ -> 0x04 - TI32 _ -> 0x05 - TI64 _ -> 0x06 - TDouble _ -> 0x07 - TString _ -> 0x08 - TBinary _ -> 0x08 - TList{} -> 0x09 - TSet{} -> 0x0A - TMap{} -> 0x0B - TStruct{} -> 0x0C - -typeFrom :: Word8 -> ThriftType -typeFrom w = case w of - 0x01 -> T_BOOL - 0x02 -> T_BOOL - 0x03 -> T_BYTE - 0x04 -> T_I16 - 0x05 -> T_I32 - 0x06 -> T_I64 - 0x07 -> T_DOUBLE - 0x08 -> T_STRING - 0x09 -> T_LIST T_VOID - 0x0A -> T_SET T_VOID - 0x0B -> T_MAP T_VOID T_VOID - 0x0C -> T_STRUCT Map.empty - n -> error $ "typeFrom: " ++ show n ++ " is not a compact type" diff --git a/lib/hs/src/Thrift/Protocol/Header.hs b/lib/hs/src/Thrift/Protocol/Header.hs deleted file mode 100644 index 5f42db45d..000000000 --- a/lib/hs/src/Thrift/Protocol/Header.hs +++ /dev/null @@ -1,141 +0,0 @@ --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - - -module Thrift.Protocol.Header - ( module Thrift.Protocol - , HeaderProtocol(..) - , getProtocolType - , setProtocolType - , getHeaders - , getWriteHeaders - , setHeader - , setHeaders - , createHeaderProtocol - , createHeaderProtocol1 - ) where - -import Thrift.Protocol -import Thrift.Protocol.Binary -import Thrift.Protocol.JSON -import Thrift.Protocol.Compact -import Thrift.Transport -import Thrift.Transport.Header -import Data.IORef -import qualified Data.Map as Map - -data ProtocolWrap = forall a. (Protocol a) => ProtocolWrap(a) - -instance Protocol ProtocolWrap where - readByte (ProtocolWrap p) = readByte p - readVal (ProtocolWrap p) = readVal p - readMessage (ProtocolWrap p) = readMessage p - writeVal (ProtocolWrap p) = writeVal p - writeMessage (ProtocolWrap p) = writeMessage p - -data HeaderProtocol i o = (Transport i, Transport o) => HeaderProtocol { - trans :: HeaderTransport i o, - wrappedProto :: IORef ProtocolWrap - } - -createProtocolWrap :: Transport t => ProtocolType -> t -> ProtocolWrap -createProtocolWrap typ t = - case typ of - TBinary -> ProtocolWrap $ BinaryProtocol t - TCompact -> ProtocolWrap $ CompactProtocol t - TJSON -> ProtocolWrap $ JSONProtocol t - -createHeaderProtocol :: (Transport i, Transport o) => i -> o -> IO(HeaderProtocol i o) -createHeaderProtocol i o = do - t <- openHeaderTransport i o - pid <- readIORef $ protocolType t - proto <- newIORef $ createProtocolWrap pid t - return $ HeaderProtocol { trans = t, wrappedProto = proto } - -createHeaderProtocol1 :: Transport t => t -> IO(HeaderProtocol t t) -createHeaderProtocol1 t = createHeaderProtocol t t - -resetProtocol :: (Transport i, Transport o) => HeaderProtocol i o -> IO () -resetProtocol p = do - pid <- readIORef $ protocolType $ trans p - writeIORef (wrappedProto p) $ createProtocolWrap pid $ trans p - -getWrapped = readIORef . wrappedProto - -setTransport :: (Transport i, Transport o) => HeaderProtocol i o -> HeaderTransport i o -> HeaderProtocol i o -setTransport p t = p { trans = t } - -updateTransport :: (Transport i, Transport o) => HeaderProtocol i o -> (HeaderTransport i o -> HeaderTransport i o)-> HeaderProtocol i o -updateTransport p f = setTransport p (f $ trans p) - -type Headers = Map.Map String String - --- TODO: we want to set headers without recreating client... -setHeader :: (Transport i, Transport o) => HeaderProtocol i o -> String -> String -> HeaderProtocol i o -setHeader p k v = updateTransport p $ \t -> t { writeHeaders = Map.insert k v $ writeHeaders t } - -setHeaders :: (Transport i, Transport o) => HeaderProtocol i o -> Headers -> HeaderProtocol i o -setHeaders p h = updateTransport p $ \t -> t { writeHeaders = h } - --- TODO: make it public once we have first transform implementation for Haskell -setTransforms :: (Transport i, Transport o) => HeaderProtocol i o -> [TransformType] -> HeaderProtocol i o -setTransforms p trs = updateTransport p $ \t -> t { writeTransforms = trs } - -setTransform :: (Transport i, Transport o) => HeaderProtocol i o -> TransformType -> HeaderProtocol i o -setTransform p tr = updateTransport p $ \t -> t { writeTransforms = tr:(writeTransforms t) } - -getWriteHeaders :: (Transport i, Transport o) => HeaderProtocol i o -> Headers -getWriteHeaders = writeHeaders . trans - -getHeaders :: (Transport i, Transport o) => HeaderProtocol i o -> IO [(String, String)] -getHeaders = readIORef . headers . trans - -getProtocolType :: (Transport i, Transport o) => HeaderProtocol i o -> IO ProtocolType -getProtocolType p = readIORef $ protocolType $ trans p - -setProtocolType :: (Transport i, Transport o) => HeaderProtocol i o -> ProtocolType -> IO () -setProtocolType p typ = do - typ0 <- getProtocolType p - if typ == typ0 - then return () - else do - tSetProtocol (trans p) typ - resetProtocol p - -instance (Transport i, Transport o) => Protocol (HeaderProtocol i o) where - readByte p = tReadAll (trans p) 1 - - readVal p tp = do - proto <- getWrapped p - readVal proto tp - - readMessage p f = do - tResetProtocol (trans p) - resetProtocol p - proto <- getWrapped p - readMessage proto f - - writeVal p v = do - proto <- getWrapped p - writeVal proto v - - writeMessage p x f = do - proto <- getWrapped p - writeMessage proto x f - diff --git a/lib/hs/src/Thrift/Protocol/JSON.hs b/lib/hs/src/Thrift/Protocol/JSON.hs deleted file mode 100644 index 839eddc84..000000000 --- a/lib/hs/src/Thrift/Protocol/JSON.hs +++ /dev/null @@ -1,362 +0,0 @@ --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} - -module Thrift.Protocol.JSON - ( module Thrift.Protocol - , JSONProtocol(..) - ) where - -import Control.Applicative -import Control.Exception (bracket) -import Control.Monad -import Data.Attoparsec.ByteString as P -import Data.Attoparsec.ByteString.Char8 as PC -import Data.Attoparsec.ByteString.Lazy as LP -import Data.ByteString.Base64.Lazy as B64C -import Data.ByteString.Lazy.Builder as B -import Data.ByteString.Internal (c2w, w2c) -import Data.Functor -import Data.Int -import Data.List -import Data.Maybe (catMaybes) -import Data.Monoid -import Data.Text.Lazy.Encoding -import Data.Word -import qualified Data.HashMap.Strict as Map - -import Thrift.Protocol -import Thrift.Transport -import Thrift.Types - -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as LBSC -import qualified Data.Text.Lazy as LT - --- | The JSON Protocol data uses the standard 'TJSONProtocol'. Data is --- encoded as a JSON 'ByteString' -data JSONProtocol t = JSONProtocol t - -- ^ Construct a 'JSONProtocol' with a 'Transport' -getTransport :: Transport t => JSONProtocol t -> t -getTransport (JSONProtocol t) = t - -instance Transport t => Protocol (JSONProtocol t) where - readByte p = tReadAll (getTransport p) 1 - - writeMessage (JSONProtocol t) (s, ty, sq) = bracket readMessageBegin readMessageEnd . const - where - readMessageBegin = tWrite t $ toLazyByteString $ - B.char8 '[' <> buildShowable (1 :: Int32) <> - B.string8 ",\"" <> escape (encodeUtf8 s) <> B.char8 '\"' <> - B.char8 ',' <> buildShowable (fromEnum ty) <> - B.char8 ',' <> buildShowable sq <> - B.char8 ',' - readMessageEnd _ = do - tWrite t "]" - tFlush t - - readMessage p = bracket readMessageBegin readMessageEnd - where - readMessageBegin = runParser p $ skipSpace *> do - _ver :: Int32 <- lexeme (PC.char8 '[') *> lexeme (signed decimal) - bs <- lexeme (PC.char8 ',') *> lexeme escapedString - case decodeUtf8' bs of - Left _ -> fail "readMessage: invalid text encoding" - Right str -> do - ty <- toEnum <$> (lexeme (PC.char8 ',') *> lexeme (signed decimal)) - seqNum <- lexeme (PC.char8 ',') *> lexeme (signed decimal) - _ <- PC.char8 ',' - return (str, ty, seqNum) - readMessageEnd _ = void $ runParser p (PC.char8 ']') - - writeVal p = tWrite (getTransport p) . toLazyByteString . buildJSONValue - readVal p ty = runParser p $ skipSpace *> parseJSONValue ty - -instance Transport t => StatelessProtocol (JSONProtocol t) where - serializeVal _ = toLazyByteString . buildJSONValue - deserializeVal _ ty bs = - case LP.eitherResult $ LP.parse (parseJSONValue ty) bs of - Left s -> error s - Right val -> val - --- Writing Functions - -buildJSONValue :: ThriftVal -> Builder -buildJSONValue (TStruct fields) = B.char8 '{' <> buildJSONStruct fields <> B.char8 '}' -buildJSONValue (TMap kt vt entries) = - B.char8 '[' <> B.char8 '"' <> getTypeName kt <> B.char8 '"' <> - B.char8 ',' <> B.char8 '"' <> getTypeName vt <> B.char8 '"' <> - B.char8 ',' <> buildShowable (length entries) <> - B.char8 ',' <> B.char8 '{' <> buildJSONMap entries <> B.char8 '}' <> - B.char8 ']' -buildJSONValue (TList ty entries) = - B.char8 '[' <> B.char8 '"' <> getTypeName ty <> B.char8 '"' <> - B.char8 ',' <> buildShowable (length entries) <> - (if length entries > 0 - then B.char8 ',' <> buildJSONList entries - else mempty) <> - B.char8 ']' -buildJSONValue (TSet ty entries) = buildJSONValue (TList ty entries) -buildJSONValue (TBool b) = if b then B.char8 '1' else B.char8 '0' -buildJSONValue (TByte b) = buildShowable b -buildJSONValue (TI16 i) = buildShowable i -buildJSONValue (TI32 i) = buildShowable i -buildJSONValue (TI64 i) = buildShowable i -buildJSONValue (TDouble d) = buildShowable d -buildJSONValue (TString s) = B.char8 '\"' <> escape s <> B.char8 '\"' -buildJSONValue (TBinary s) = B.char8 '\"' <> (B.lazyByteString . B64C.encode $ s) <> B.char8 '\"' - -buildJSONStruct :: Map.HashMap Int16 (LT.Text, ThriftVal) -> Builder -buildJSONStruct = mconcat . intersperse (B.char8 ',') . Map.foldrWithKey buildField [] - where - buildField fid (_,val) = (:) $ - B.char8 '"' <> buildShowable fid <> B.string8 "\":" <> - B.char8 '{' <> - B.char8 '"' <> getTypeName (getTypeOf val) <> B.string8 "\":" <> - buildJSONValue val <> - B.char8 '}' - -buildJSONMap :: [(ThriftVal, ThriftVal)] -> Builder -buildJSONMap = mconcat . intersperse (B.char8 ',') . map buildKV - where - buildKV (key@(TString _), val) = - buildJSONValue key <> B.char8 ':' <> buildJSONValue val - buildKV (key, val) = - B.char8 '\"' <> buildJSONValue key <> B.string8 "\":" <> buildJSONValue val -buildJSONList :: [ThriftVal] -> Builder -buildJSONList = mconcat . intersperse (B.char8 ',') . map buildJSONValue - -buildShowable :: Show a => a -> Builder -buildShowable = B.string8 . show - --- Reading Functions - -parseJSONValue :: ThriftType -> Parser ThriftVal -parseJSONValue (T_STRUCT tmap) = - TStruct <$> (lexeme (PC.char8 '{') *> parseJSONStruct tmap <* PC.char8 '}') -parseJSONValue (T_MAP kt vt) = fmap (TMap kt vt) $ - between '[' ']' $ - lexeme escapedString *> lexeme (PC.char8 ',') *> - lexeme escapedString *> lexeme (PC.char8 ',') *> - lexeme decimal *> lexeme (PC.char8 ',') *> - between '{' '}' (parseJSONMap kt vt) -parseJSONValue (T_LIST ty) = fmap (TList ty) $ - between '[' ']' $ do - len <- lexeme escapedString *> lexeme (PC.char8 ',') *> lexeme decimal - if len > 0 - then lexeme (PC.char8 ',') *> parseJSONList ty - else return [] -parseJSONValue (T_SET ty) = fmap (TSet ty) $ - between '[' ']' $ do - len <- lexeme escapedString *> lexeme (PC.char8 ',') *> lexeme decimal - if len > 0 - then lexeme (PC.char8 ',') *> parseJSONList ty - else return [] -parseJSONValue T_BOOL = - (TBool True <$ PC.char8 '1') <|> (TBool False <$ PC.char8 '0') -parseJSONValue T_BYTE = TByte <$> signed decimal -parseJSONValue T_I16 = TI16 <$> signed decimal -parseJSONValue T_I32 = TI32 <$> signed decimal -parseJSONValue T_I64 = TI64 <$> signed decimal -parseJSONValue T_DOUBLE = TDouble <$> double -parseJSONValue T_STRING = TString <$> escapedString -parseJSONValue T_BINARY = TBinary <$> base64String -parseJSONValue T_STOP = fail "parseJSONValue: cannot parse type T_STOP" -parseJSONValue T_VOID = fail "parseJSONValue: cannot parse type T_VOID" - -parseAnyValue :: Parser () -parseAnyValue = choice $ - skipBetween '{' '}' : - skipBetween '[' ']' : - map (void . parseJSONValue) - [ T_BOOL - , T_I16 - , T_I32 - , T_I64 - , T_DOUBLE - , T_STRING - , T_BINARY - ] - where - skipBetween :: Char -> Char -> Parser () - skipBetween a b = between a b $ void (PC.satisfy (\c -> c /= a && c /= b)) - <|> skipBetween a b - -parseJSONStruct :: TypeMap -> Parser (Map.HashMap Int16 (LT.Text, ThriftVal)) -parseJSONStruct tmap = Map.fromList . catMaybes <$> parseField - `sepBy` lexeme (PC.char8 ',') - where - parseField = do - fid <- lexeme (between '"' '"' decimal) <* lexeme (PC.char8 ':') - case Map.lookup fid tmap of - Just (str, ftype) -> between '{' '}' $ do - _ <- lexeme (escapedString) *> lexeme (PC.char8 ':') - val <- lexeme (parseJSONValue ftype) - return $ Just (fid, (str, val)) - Nothing -> lexeme parseAnyValue *> return Nothing - -parseJSONMap :: ThriftType -> ThriftType -> Parser [(ThriftVal, ThriftVal)] -parseJSONMap kt vt = - ((,) <$> lexeme (parseJSONKey kt) <*> - (lexeme (PC.char8 ':') *> lexeme (parseJSONValue vt))) `sepBy` - lexeme (PC.char8 ',') - where - parseJSONKey T_STRING = parseJSONValue T_STRING - parseJSONKey T_BINARY = parseJSONValue T_BINARY - parseJSONKey kt = PC.char8 '"' *> parseJSONValue kt <* PC.char8 '"' - -parseJSONList :: ThriftType -> Parser [ThriftVal] -parseJSONList ty = lexeme (parseJSONValue ty) `sepBy` lexeme (PC.char8 ',') - -escapedString :: Parser LBS.ByteString -escapedString = PC.char8 '"' *> - (LBS.pack <$> P.many' (escapedChar <|> notChar8 '"')) <* - PC.char8 '"' - -base64String :: Parser LBS.ByteString -base64String = PC.char8 '"' *> - (decodeBase64 . LBSC.pack <$> P.many' (PC.notChar '"')) <* - PC.char8 '"' - where - decodeBase64 b = - let padded = case (LBS.length b) `mod` 4 of - 2 -> LBS.append b "==" - 3 -> LBS.append b "=" - _ -> b in - case B64C.decode padded of - Right s -> s - Left x -> error x - -escapedChar :: Parser Word8 -escapedChar = PC.char8 '\\' *> (c2w <$> choice - [ '\SOH' <$ P.string "u0001" - , '\STX' <$ P.string "u0002" - , '\ETX' <$ P.string "u0003" - , '\EOT' <$ P.string "u0004" - , '\ENQ' <$ P.string "u0005" - , '\ACK' <$ P.string "u0006" - , '\BEL' <$ P.string "u0007" - , '\BS' <$ P.string "u0008" - , '\VT' <$ P.string "u000b" - , '\FF' <$ P.string "u000c" - , '\CR' <$ P.string "u000d" - , '\SO' <$ P.string "u000e" - , '\SI' <$ P.string "u000f" - , '\DLE' <$ P.string "u0010" - , '\DC1' <$ P.string "u0011" - , '\DC2' <$ P.string "u0012" - , '\DC3' <$ P.string "u0013" - , '\DC4' <$ P.string "u0014" - , '\NAK' <$ P.string "u0015" - , '\SYN' <$ P.string "u0016" - , '\ETB' <$ P.string "u0017" - , '\CAN' <$ P.string "u0018" - , '\EM' <$ P.string "u0019" - , '\SUB' <$ P.string "u001a" - , '\ESC' <$ P.string "u001b" - , '\FS' <$ P.string "u001c" - , '\GS' <$ P.string "u001d" - , '\RS' <$ P.string "u001e" - , '\US' <$ P.string "u001f" - , '\DEL' <$ P.string "u007f" - , '\0' <$ PC.char '0' - , '\a' <$ PC.char 'a' - , '\b' <$ PC.char 'b' - , '\f' <$ PC.char 'f' - , '\n' <$ PC.char 'n' - , '\r' <$ PC.char 'r' - , '\t' <$ PC.char 't' - , '\v' <$ PC.char 'v' - , '\"' <$ PC.char '"' - , '\'' <$ PC.char '\'' - , '\\' <$ PC.char '\\' - , '/' <$ PC.char '/' - ]) - -escape :: LBS.ByteString -> Builder -escape = LBS.foldl' escapeChar mempty - where - escapeChar b w = b <> (B.lazyByteString $ case w2c w of - '\0' -> "\\0" - '\b' -> "\\b" - '\f' -> "\\f" - '\n' -> "\\n" - '\r' -> "\\r" - '\t' -> "\\t" - '\"' -> "\\\"" - '\\' -> "\\\\" - '\SOH' -> "\\u0001" - '\STX' -> "\\u0002" - '\ETX' -> "\\u0003" - '\EOT' -> "\\u0004" - '\ENQ' -> "\\u0005" - '\ACK' -> "\\u0006" - '\BEL' -> "\\u0007" - '\VT' -> "\\u000b" - '\SO' -> "\\u000e" - '\SI' -> "\\u000f" - '\DLE' -> "\\u0010" - '\DC1' -> "\\u0011" - '\DC2' -> "\\u0012" - '\DC3' -> "\\u0013" - '\DC4' -> "\\u0014" - '\NAK' -> "\\u0015" - '\SYN' -> "\\u0016" - '\ETB' -> "\\u0017" - '\CAN' -> "\\u0018" - '\EM' -> "\\u0019" - '\SUB' -> "\\u001a" - '\ESC' -> "\\u001b" - '\FS' -> "\\u001c" - '\GS' -> "\\u001d" - '\RS' -> "\\u001e" - '\US' -> "\\u001f" - '\DEL' -> "\\u007f" - _ -> LBS.singleton w) - -lexeme :: Parser a -> Parser a -lexeme = (<* skipSpace) - -notChar8 :: Char -> Parser Word8 -notChar8 c = P.satisfy (/= c2w c) - -between :: Char -> Char -> Parser a -> Parser a -between a b p = lexeme (PC.char8 a) *> lexeme p <* lexeme (PC.char8 b) - -getTypeName :: ThriftType -> Builder -getTypeName ty = B.string8 $ case ty of - T_STRUCT _ -> "rec" - T_MAP _ _ -> "map" - T_LIST _ -> "lst" - T_SET _ -> "set" - T_BOOL -> "tf" - T_BYTE -> "i8" - T_I16 -> "i16" - T_I32 -> "i32" - T_I64 -> "i64" - T_DOUBLE -> "dbl" - T_STRING -> "str" - T_BINARY -> "str" - _ -> error "Unrecognized Type" - diff --git a/lib/hs/src/Thrift/Server.hs b/lib/hs/src/Thrift/Server.hs deleted file mode 100644 index 543f33850..000000000 --- a/lib/hs/src/Thrift/Server.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -module Thrift.Server - ( runBasicServer - , runThreadedServer - ) where - -import Control.Concurrent ( forkIO ) -import Control.Exception -import Control.Monad ( forever, when ) - -import Network - -import System.IO - -import Thrift -import Thrift.Transport.Handle() -import Thrift.Protocol.Binary - - --- | A threaded sever that is capable of using any Transport or Protocol --- instances. -runThreadedServer :: (Protocol i, Protocol o) - => (Socket -> IO (i, o)) - -> h - -> (h -> (i, o) -> IO Bool) - -> PortID - -> IO a -runThreadedServer accepter hand proc_ port = do - socket <- listenOn port - acceptLoop (accepter socket) (proc_ hand) - --- | A basic threaded binary protocol socket server. -runBasicServer :: h - -> (h -> (BinaryProtocol Handle, BinaryProtocol Handle) -> IO Bool) - -> PortNumber - -> IO a -runBasicServer hand proc_ port = runThreadedServer binaryAccept hand proc_ (PortNumber port) - where binaryAccept s = do - (h, _, _) <- accept s - return (BinaryProtocol h, BinaryProtocol h) - -acceptLoop :: IO t -> (t -> IO Bool) -> IO a -acceptLoop accepter proc_ = forever $ - do ps <- accepter - forkIO $ handle (\(_ :: SomeException) -> return ()) - (loop $ proc_ ps) - where loop m = do { continue <- m; when continue (loop m) } diff --git a/lib/hs/src/Thrift/Transport.hs b/lib/hs/src/Thrift/Transport.hs deleted file mode 100644 index 306edc208..000000000 --- a/lib/hs/src/Thrift/Transport.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE MultiParamTypeClasses #-} --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -module Thrift.Transport - ( Transport(..) - , TransportExn(..) - , TransportExnType(..) - ) where - -import Control.Monad ( when ) -import Control.Exception ( Exception, throw ) -import Data.Functor ( (<$>) ) -import Data.Typeable ( Typeable ) -import Data.Word - -import qualified Data.ByteString.Lazy as LBS -import Data.Monoid - -class Transport a where - tIsOpen :: a -> IO Bool - tClose :: a -> IO () - tRead :: a -> Int -> IO LBS.ByteString - tPeek :: a -> IO (Maybe Word8) - tWrite :: a -> LBS.ByteString -> IO () - tFlush :: a -> IO () - tReadAll :: a -> Int -> IO LBS.ByteString - - tReadAll _ 0 = return mempty - tReadAll a len = do - result <- tRead a len - let rlen = fromIntegral $ LBS.length result - when (rlen == 0) (throw $ TransportExn "Cannot read. Remote side has closed." TE_UNKNOWN) - if len <= rlen - then return result - else (result `mappend`) <$> tReadAll a (len - rlen) - -data TransportExn = TransportExn String TransportExnType - deriving ( Show, Typeable ) -instance Exception TransportExn - -data TransportExnType - = TE_UNKNOWN - | TE_NOT_OPEN - | TE_ALREADY_OPEN - | TE_TIMED_OUT - | TE_END_OF_FILE - deriving ( Eq, Show, Typeable ) diff --git a/lib/hs/src/Thrift/Transport/Empty.hs b/lib/hs/src/Thrift/Transport/Empty.hs deleted file mode 100644 index 47af5fe88..000000000 --- a/lib/hs/src/Thrift/Transport/Empty.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -module Thrift.Transport.Empty - ( EmptyTransport(..) - ) where - -import Thrift.Transport - -data EmptyTransport = EmptyTransport - -instance Transport EmptyTransport where - tIsOpen = const $ return False - tClose = const $ return () - tRead _ _ = return "" - tPeek = const $ return Nothing - tWrite _ _ = return () - tFlush = const$ return () diff --git a/lib/hs/src/Thrift/Transport/Framed.hs b/lib/hs/src/Thrift/Transport/Framed.hs deleted file mode 100644 index ad553aed8..000000000 --- a/lib/hs/src/Thrift/Transport/Framed.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -module Thrift.Transport.Framed - ( module Thrift.Transport - , FramedTransport - , openFramedTransport - ) where - -import Thrift.Transport -import Thrift.Transport.IOBuffer - -import Data.Int (Int32) -import qualified Data.Binary as B -import qualified Data.ByteString.Lazy as LBS - - --- | FramedTransport wraps a given transport in framed mode. -data FramedTransport t = FramedTransport { - wrappedTrans :: t, -- ^ Underlying transport. - writeBuffer :: WriteBuffer, -- ^ Write buffer. - readBuffer :: ReadBuffer -- ^ Read buffer. - } - --- | Create a new framed transport which wraps the given transport. -openFramedTransport :: Transport t => t -> IO (FramedTransport t) -openFramedTransport trans = do - wbuf <- newWriteBuffer - rbuf <- newReadBuffer - return FramedTransport{ wrappedTrans = trans, writeBuffer = wbuf, readBuffer = rbuf } - -instance Transport t => Transport (FramedTransport t) where - - tClose = tClose . wrappedTrans - - tRead trans n = do - -- First, check the read buffer for any data. - bs <- readBuf (readBuffer trans) n - if LBS.null bs - then - -- When the buffer is empty, read another frame from the - -- underlying transport. - do len <- readFrame trans - if len > 0 - then tRead trans n - else return bs - else return bs - tPeek trans = do - mw <- peekBuf (readBuffer trans) - case mw of - Just _ -> return mw - Nothing -> do - len <- readFrame trans - if len > 0 - then tPeek trans - else return Nothing - - tWrite = writeBuf . writeBuffer - - tFlush trans = do - bs <- flushBuf (writeBuffer trans) - let szBs = B.encode $ (fromIntegral $ LBS.length bs :: Int32) - tWrite (wrappedTrans trans) szBs - tWrite (wrappedTrans trans) bs - tFlush (wrappedTrans trans) - - tIsOpen = tIsOpen . wrappedTrans - -readFrame :: Transport t => FramedTransport t -> IO Int -readFrame trans = do - -- Read and decode the frame size. - szBs <- tReadAll (wrappedTrans trans) 4 - let sz = fromIntegral (B.decode szBs :: Int32) - - -- Read the frame and stuff it into the read buffer. - bs <- tReadAll (wrappedTrans trans) sz - fillBuf (readBuffer trans) bs - - -- Return the frame size so that the caller knows whether to expect - -- something in the read buffer or not. - return sz diff --git a/lib/hs/src/Thrift/Transport/Handle.hs b/lib/hs/src/Thrift/Transport/Handle.hs deleted file mode 100644 index 528a02793..000000000 --- a/lib/hs/src/Thrift/Transport/Handle.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -module Thrift.Transport.Handle - ( module Thrift.Transport - , HandleSource(..) - ) where - -import Control.Exception ( catch, throw ) -import Control.Monad ( when ) -import Data.ByteString.Internal (c2w) -import Data.Functor - -import Network - -import System.IO -import System.IO.Error ( isEOFError ) - -import Thrift.Transport - -import qualified Data.ByteString.Lazy as LBS -import Data.Monoid - -instance Transport Handle where - tIsOpen = hIsOpen - tClose = hClose - tRead h n = read `Control.Exception.catch` handleEOF mempty - where - read = do - hLookAhead h - LBS.hGetNonBlocking h n - tReadAll _ 0 = return mempty - tReadAll h n = do - result <- LBS.hGet h n `Control.Exception.catch` throwTransportExn - let rlen = fromIntegral $ LBS.length result - when (rlen == 0) (throw $ TransportExn "Cannot read. Remote side has closed." TE_UNKNOWN) - if n <= rlen - then return result - else (result `mappend`) <$> tReadAll h (n - rlen) - tPeek h = (Just . c2w <$> hLookAhead h) `Control.Exception.catch` handleEOF Nothing - tWrite = LBS.hPut - tFlush = hFlush - - --- | Type class for all types that can open a Handle. This class is used to --- replace tOpen in the Transport type class. -class HandleSource s where - hOpen :: s -> IO Handle - -instance HandleSource FilePath where - hOpen s = openFile s ReadWriteMode - -instance HandleSource (HostName, PortID) where - hOpen = uncurry connectTo - -throwTransportExn :: IOError -> IO a -throwTransportExn e = if isEOFError e - then throw $ TransportExn "Cannot read. Remote side has closed." TE_UNKNOWN - else throw $ TransportExn "Handle tReadAll: Could not read" TE_UNKNOWN - -handleEOF :: a -> IOError -> IO a -handleEOF a e = if isEOFError e - then return a - else throw $ TransportExn "Handle: Could not read" TE_UNKNOWN diff --git a/lib/hs/src/Thrift/Transport/Header.hs b/lib/hs/src/Thrift/Transport/Header.hs deleted file mode 100644 index 2dacad25f..000000000 --- a/lib/hs/src/Thrift/Transport/Header.hs +++ /dev/null @@ -1,354 +0,0 @@ --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -module Thrift.Transport.Header - ( module Thrift.Transport - , HeaderTransport(..) - , openHeaderTransport - , ProtocolType(..) - , TransformType(..) - , ClientType(..) - , tResetProtocol - , tSetProtocol - ) where - -import Thrift.Transport -import Thrift.Protocol.Compact -import Control.Applicative -import Control.Exception ( throw ) -import Control.Monad -import Data.Bits -import Data.IORef -import Data.Int -import Data.Monoid -import Data.Word - -import qualified Data.Attoparsec.ByteString as P -import qualified Data.Binary as Binary -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Builder as B -import qualified Data.Map as Map - -data ProtocolType = TBinary | TCompact | TJSON deriving (Enum, Eq) -data ClientType = HeaderClient | Framed | Unframed deriving (Enum, Eq) - -infoIdKeyValue = 1 - -type Headers = Map.Map String String - -data TransformType = ZlibTransform deriving (Enum, Eq) - -fromTransportType :: TransformType -> Int16 -fromTransportType ZlibTransform = 1 - -toTransportType :: Int16 -> TransformType -toTransportType 1 = ZlibTransform -toTransportType _ = throw $ TransportExn "HeaderTransport: Unknown transform ID" TE_UNKNOWN - -data HeaderTransport i o = (Transport i, Transport o) => HeaderTransport - { readBuffer :: IORef LBS.ByteString - , writeBuffer :: IORef B.Builder - , inTrans :: i - , outTrans :: o - , clientType :: IORef ClientType - , protocolType :: IORef ProtocolType - , headers :: IORef [(String, String)] - , writeHeaders :: Headers - , transforms :: IORef [TransformType] - , writeTransforms :: [TransformType] - } - -openHeaderTransport :: (Transport i, Transport o) => i -> o -> IO (HeaderTransport i o) -openHeaderTransport i o = do - pid <- newIORef TCompact - rBuf <- newIORef LBS.empty - wBuf <- newIORef mempty - cType <- newIORef HeaderClient - h <- newIORef [] - trans <- newIORef [] - return HeaderTransport - { readBuffer = rBuf - , writeBuffer = wBuf - , inTrans = i - , outTrans = o - , clientType = cType - , protocolType = pid - , headers = h - , writeHeaders = Map.empty - , transforms = trans - , writeTransforms = [] - } - -isFramed t = (/= Unframed) <$> readIORef (clientType t) - -readFrame :: (Transport i, Transport o) => HeaderTransport i o -> IO Bool -readFrame t = do - let input = inTrans t - let rBuf = readBuffer t - let cType = clientType t - lsz <- tRead input 4 - let sz = LBS.toStrict lsz - case P.parseOnly P.endOfInput sz of - Right _ -> do return False - Left _ -> do - case parseBinaryMagic sz of - Right _ -> do - writeIORef rBuf $ lsz - writeIORef cType Unframed - writeIORef (protocolType t) TBinary - return True - Left _ -> do - case parseCompactMagic sz of - Right _ -> do - writeIORef rBuf $ lsz - writeIORef cType Unframed - writeIORef (protocolType t) TCompact - return True - Left _ -> do - let len = Binary.decode lsz :: Int32 - lbuf <- tReadAll input $ fromIntegral len - let buf = LBS.toStrict lbuf - case parseBinaryMagic buf of - Right _ -> do - writeIORef cType Framed - writeIORef (protocolType t) TBinary - writeIORef rBuf lbuf - return True - Left _ -> do - case parseCompactMagic buf of - Right _ -> do - writeIORef cType Framed - writeIORef (protocolType t) TCompact - writeIORef rBuf lbuf - return True - Left _ -> do - case parseHeaderMagic buf of - Right flags -> do - let (flags, seqNum, header, body) = extractHeader buf - writeIORef cType HeaderClient - handleHeader t header - payload <- untransform t body - writeIORef rBuf $ LBS.fromStrict $ payload - return True - Left _ -> - throw $ TransportExn "HeaderTransport: unkonwn client type" TE_UNKNOWN - -parseBinaryMagic = P.parseOnly $ P.word8 0x80 *> P.word8 0x01 *> P.word8 0x00 *> P.anyWord8 -parseCompactMagic = P.parseOnly $ P.word8 0x82 *> P.satisfy (\b -> b .&. 0x1f == 0x01) -parseHeaderMagic = P.parseOnly $ P.word8 0x0f *> P.word8 0xff *> (P.count 2 P.anyWord8) - -parseI32 :: P.Parser Int32 -parseI32 = Binary.decode . LBS.fromStrict <$> P.take 4 -parseI16 :: P.Parser Int16 -parseI16 = Binary.decode . LBS.fromStrict <$> P.take 2 - -extractHeader :: BS.ByteString -> (Int16, Int32, BS.ByteString, BS.ByteString) -extractHeader bs = - case P.parse extractHeader_ bs of - P.Done remain (flags, seqNum, header) -> (flags, seqNum, header, remain) - _ -> throw $ TransportExn "HeaderTransport: Invalid header" TE_UNKNOWN - where - extractHeader_ = do - magic <- P.word8 0x0f *> P.word8 0xff - flags <- parseI16 - seqNum <- parseI32 - (headerSize :: Int) <- (* 4) . fromIntegral <$> parseI16 - header <- P.take headerSize - return (flags, seqNum, header) - -handleHeader t header = - case P.parseOnly parseHeader header of - Right (pType, trans, info) -> do - writeIORef (protocolType t) pType - writeIORef (transforms t) trans - writeIORef (headers t) info - _ -> throw $ TransportExn "HeaderTransport: Invalid header" TE_UNKNOWN - - -iw16 :: Int16 -> Word16 -iw16 = fromIntegral -iw32 :: Int32 -> Word32 -iw32 = fromIntegral -wi16 :: Word16 -> Int16 -wi16 = fromIntegral -wi32 :: Word32 -> Int32 -wi32 = fromIntegral - -parseHeader :: P.Parser (ProtocolType, [TransformType], [(String, String)]) -parseHeader = do - protocolType <- toProtocolType <$> parseVarint wi16 - numTrans <- fromIntegral <$> parseVarint wi16 - trans <- replicateM numTrans parseTransform - info <- parseInfo - return (protocolType, trans, info) - -toProtocolType :: Int16 -> ProtocolType -toProtocolType 0 = TBinary -toProtocolType 1 = TJSON -toProtocolType 2 = TCompact - -fromProtocolType :: ProtocolType -> Int16 -fromProtocolType TBinary = 0 -fromProtocolType TJSON = 1 -fromProtocolType TCompact = 2 - -parseTransform :: P.Parser TransformType -parseTransform = toTransportType <$> parseVarint wi16 - -parseInfo :: P.Parser [(String, String)] -parseInfo = do - n <- P.eitherP P.endOfInput (parseVarint wi32) - case n of - Left _ -> return [] - Right n0 -> - replicateM (fromIntegral n0) $ do - klen <- parseVarint wi16 - k <- P.take $ fromIntegral klen - vlen <- parseVarint wi16 - v <- P.take $ fromIntegral vlen - return (C.unpack k, C.unpack v) - -parseString :: P.Parser BS.ByteString -parseString = parseVarint wi32 >>= (P.take . fromIntegral) - -buildHeader :: HeaderTransport i o -> IO B.Builder -buildHeader t = do - pType <- readIORef $ protocolType t - let pId = buildVarint $ iw16 $ fromProtocolType pType - let headerContent = pId <> (buildTransforms t) <> (buildInfo t) - let len = fromIntegral $ LBS.length $ B.toLazyByteString headerContent - -- TODO: length limit check - let padding = mconcat $ replicate (mod len 4) $ B.word8 0 - let codedLen = B.int16BE (fromIntegral $ (quot (len - 1) 4) + 1) - let flags = 0 - let seqNum = 0 - return $ B.int16BE 0x0fff <> B.int16BE flags <> B.int32BE seqNum <> codedLen <> headerContent <> padding - -buildTransforms :: HeaderTransport i o -> B.Builder --- TODO: check length limit -buildTransforms t = - let trans = writeTransforms t in - (buildVarint $ iw16 $ fromIntegral $ length trans) <> - (mconcat $ map (buildVarint . iw16 . fromTransportType) trans) - -buildInfo :: HeaderTransport i o -> B.Builder -buildInfo t = - let h = Map.assocs $ writeHeaders t in - -- TODO: check length limit - case length h of - 0 -> mempty - len -> (buildVarint $ iw16 $ fromIntegral $ len) <> (mconcat $ map buildInfoEntry h) - where - buildInfoEntry (k, v) = buildVarStr k <> buildVarStr v - -- TODO: check length limit - buildVarStr s = (buildVarint $ iw16 $ fromIntegral $ length s) <> B.string8 s - -tResetProtocol :: (Transport i, Transport o) => HeaderTransport i o -> IO Bool -tResetProtocol t = do - rBuf <- readIORef $ readBuffer t - writeIORef (clientType t) HeaderClient - readFrame t - -tSetProtocol :: (Transport i, Transport o) => HeaderTransport i o -> ProtocolType -> IO () -tSetProtocol t = writeIORef (protocolType t) - -transform :: HeaderTransport i o -> LBS.ByteString -> LBS.ByteString -transform t bs = - foldr applyTransform bs $ writeTransforms t - where - -- applyTransform bs ZlibTransform = - -- throw $ TransportExn "HeaderTransport: not implemented: ZlibTransform " TE_UNKNOWN - applyTransform bs _ = - throw $ TransportExn "HeaderTransport: Unknown transform" TE_UNKNOWN - -untransform :: HeaderTransport i o -> BS.ByteString -> IO BS.ByteString -untransform t bs = do - trans <- readIORef $ transforms t - return $ foldl unapplyTransform bs trans - where - -- unapplyTransform bs ZlibTransform = - -- throw $ TransportExn "HeaderTransport: not implemented: ZlibTransform " TE_UNKNOWN - unapplyTransform bs _ = - throw $ TransportExn "HeaderTransport: Unknown transform" TE_UNKNOWN - -instance (Transport i, Transport o) => Transport (HeaderTransport i o) where - tIsOpen t = do - tIsOpen (inTrans t) - tIsOpen (outTrans t) - - tClose t = do - tClose(outTrans t) - tClose(inTrans t) - - tRead t len = do - rBuf <- readIORef $ readBuffer t - if not $ LBS.null rBuf - then do - let (consumed, remain) = LBS.splitAt (fromIntegral len) rBuf - writeIORef (readBuffer t) remain - return consumed - else do - framed <- isFramed t - if not framed - then tRead (inTrans t) len - else do - ok <- readFrame t - if ok - then tRead t len - else return LBS.empty - - tPeek t = do - rBuf <- readIORef (readBuffer t) - if not $ LBS.null rBuf - then return $ Just $ LBS.head rBuf - else do - framed <- isFramed t - if not framed - then tPeek (inTrans t) - else do - ok <- readFrame t - if ok - then tPeek t - else return Nothing - - tWrite t buf = do - let wBuf = writeBuffer t - framed <- isFramed t - if framed - then modifyIORef wBuf (<> B.lazyByteString buf) - else - -- TODO: what should we do when switched to unframed in the middle ? - tWrite(outTrans t) buf - - tFlush t = do - cType <- readIORef $ clientType t - case cType of - Unframed -> tFlush $ outTrans t - Framed -> flushBuffer t id mempty - HeaderClient -> buildHeader t >>= flushBuffer t (transform t) - where - flushBuffer t f header = do - wBuf <- readIORef $ writeBuffer t - writeIORef (writeBuffer t) mempty - let payload = B.toLazyByteString (header <> wBuf) - tWrite (outTrans t) $ Binary.encode (fromIntegral $ LBS.length payload :: Int32) - tWrite (outTrans t) $ f payload - tFlush (outTrans t) diff --git a/lib/hs/src/Thrift/Transport/HttpClient.hs b/lib/hs/src/Thrift/Transport/HttpClient.hs deleted file mode 100644 index edeb3208d..000000000 --- a/lib/hs/src/Thrift/Transport/HttpClient.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -module Thrift.Transport.HttpClient - ( module Thrift.Transport - , HttpClient (..) - , openHttpClient -) where - -import Thrift.Transport -import Thrift.Transport.IOBuffer -import Network.URI -import Network.HTTP hiding (port, host) - -import Data.Maybe (fromJust) -import Data.Monoid (mempty) -import Control.Exception (throw) -import qualified Data.ByteString.Lazy as LBS - - --- | 'HttpClient', or THttpClient implements the Thrift Transport --- | Layer over http or https. -data HttpClient = - HttpClient { - hstream :: HandleStream LBS.ByteString, - uri :: URI, - writeBuffer :: WriteBuffer, - readBuffer :: ReadBuffer - } - -uriAuth :: URI -> URIAuth -uriAuth = fromJust . uriAuthority - -host :: URI -> String -host = uriRegName . uriAuth - -port :: URI -> Int -port uri_ = - if portStr == mempty then - httpPort - else - read portStr - where - portStr = dropWhile (== ':') $ uriPort $ uriAuth uri_ - httpPort = 80 - --- | Use 'openHttpClient' to create an HttpClient connected to @uri@ -openHttpClient :: URI -> IO HttpClient -openHttpClient uri_ = do - stream <- openTCPConnection (host uri_) (port uri_) - wbuf <- newWriteBuffer - rbuf <- newReadBuffer - return $ HttpClient stream uri_ wbuf rbuf - -instance Transport HttpClient where - - tClose = close . hstream - - tPeek = peekBuf . readBuffer - - tRead = readBuf . readBuffer - - tWrite = writeBuf . writeBuffer - - tFlush hclient = do - body <- flushBuf $ writeBuffer hclient - let request = Request { - rqURI = uri hclient, - rqHeaders = [ - mkHeader HdrContentType "application/x-thrift", - mkHeader HdrContentLength $ show $ LBS.length body], - rqMethod = POST, - rqBody = body - } - - res <- sendHTTP (hstream hclient) request - case res of - Right response -> - fillBuf (readBuffer hclient) (rspBody response) - Left _ -> - throw $ TransportExn "THttpConnection: HTTP failure from server" TE_UNKNOWN - return () - - tIsOpen _ = return True diff --git a/lib/hs/src/Thrift/Transport/IOBuffer.hs b/lib/hs/src/Thrift/Transport/IOBuffer.hs deleted file mode 100644 index 7ebd7d899..000000000 --- a/lib/hs/src/Thrift/Transport/IOBuffer.hs +++ /dev/null @@ -1,69 +0,0 @@ --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -module Thrift.Transport.IOBuffer - ( WriteBuffer - , newWriteBuffer - , writeBuf - , flushBuf - , ReadBuffer - , newReadBuffer - , fillBuf - , readBuf - , peekBuf - ) where - -import Data.ByteString.Lazy.Builder -import Data.Functor -import Data.IORef -import Data.Monoid -import Data.Word - -import qualified Data.ByteString.Lazy as LBS - -type WriteBuffer = IORef Builder -type ReadBuffer = IORef LBS.ByteString - -newWriteBuffer :: IO WriteBuffer -newWriteBuffer = newIORef mempty - -writeBuf :: WriteBuffer -> LBS.ByteString -> IO () -writeBuf w s = modifyIORef w ( <> lazyByteString s) - -flushBuf :: WriteBuffer -> IO LBS.ByteString -flushBuf w = do - buf <- readIORef w - writeIORef w mempty - return $ toLazyByteString buf - -newReadBuffer :: IO ReadBuffer -newReadBuffer = newIORef mempty - -fillBuf :: ReadBuffer -> LBS.ByteString -> IO () -fillBuf = writeIORef - -readBuf :: ReadBuffer -> Int -> IO LBS.ByteString -readBuf r n = do - bs <- readIORef r - let (hd, tl) = LBS.splitAt (fromIntegral n) bs - writeIORef r tl - return hd - -peekBuf :: ReadBuffer -> IO (Maybe Word8) -peekBuf r = (fmap fst . LBS.uncons) <$> readIORef r diff --git a/lib/hs/src/Thrift/Transport/Memory.hs b/lib/hs/src/Thrift/Transport/Memory.hs deleted file mode 100644 index 1c93af695..000000000 --- a/lib/hs/src/Thrift/Transport/Memory.hs +++ /dev/null @@ -1,77 +0,0 @@ --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -module Thrift.Transport.Memory - ( openMemoryBuffer - , MemoryBuffer(..) - ) where - -import Data.ByteString.Lazy.Builder -import Data.Functor -import Data.IORef -import Data.Monoid -import qualified Data.ByteString.Lazy as LBS - -import Thrift.Transport - - -data MemoryBuffer = MemoryBuffer { - writeBuffer :: IORef Builder, - readBuffer :: IORef LBS.ByteString -} - -openMemoryBuffer :: IO MemoryBuffer -openMemoryBuffer = do - wbuf <- newIORef mempty - rbuf <- newIORef mempty - return MemoryBuffer { - writeBuffer = wbuf, - readBuffer = rbuf - } - -instance Transport MemoryBuffer where - tIsOpen = const $ return False - tClose = const $ return () - tFlush trans = do - let wBuf = writeBuffer trans - wb <- readIORef wBuf - modifyIORef (readBuffer trans) $ \rb -> mappend rb $ toLazyByteString wb - writeIORef wBuf mempty - - tRead _ 0 = return mempty - tRead trans n = do - let rbuf = readBuffer trans - rb <- readIORef rbuf - let len = fromIntegral $ LBS.length rb - if len == 0 - then do - tFlush trans - rb2 <- readIORef (readBuffer trans) - if (fromIntegral $ LBS.length rb2) == 0 - then return mempty - else tRead trans n - else do - let (ret, remain) = LBS.splitAt (fromIntegral n) rb - writeIORef rbuf remain - return ret - - tPeek trans = (fmap fst . LBS.uncons) <$> readIORef (readBuffer trans) - - tWrite trans v = do - modifyIORef (writeBuffer trans) (<> lazyByteString v) diff --git a/lib/hs/src/Thrift/Types.hs b/lib/hs/src/Thrift/Types.hs deleted file mode 100644 index 2a200253d..000000000 --- a/lib/hs/src/Thrift/Types.hs +++ /dev/null @@ -1,130 +0,0 @@ --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Thrift.Types where - -import Data.Foldable (foldl') -import Data.Hashable ( Hashable, hashWithSalt ) -import Data.Int -import Test.QuickCheck.Arbitrary -import Test.QuickCheck.Gen (elements) -import Data.Text.Lazy (Text) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import qualified Data.Vector as Vector - -instance (Hashable a) => Hashable (Vector.Vector a) where - hashWithSalt = Vector.foldl' hashWithSalt - - -type TypeMap = Map.HashMap Int16 (Text, ThriftType) - -data ThriftVal = TStruct (Map.HashMap Int16 (Text, ThriftVal)) - | TMap ThriftType ThriftType [(ThriftVal, ThriftVal)] - | TList ThriftType [ThriftVal] - | TSet ThriftType [ThriftVal] - | TBool Bool - | TByte Int8 - | TI16 Int16 - | TI32 Int32 - | TI64 Int64 - | TString LBS.ByteString - | TBinary LBS.ByteString - | TDouble Double - deriving (Eq, Show) - --- Information is needed here for collection types (ie T_STRUCT, T_MAP, --- T_LIST, and T_SET) so that we know what types those collections are --- parameterized by. In most protocols, this cannot be discerned directly --- from the data being read. -data ThriftType - = T_STOP - | T_VOID - | T_BOOL - | T_BYTE - | T_DOUBLE - | T_I16 - | T_I32 - | T_I64 - | T_STRING - | T_BINARY - | T_STRUCT TypeMap - | T_MAP ThriftType ThriftType - | T_SET ThriftType - | T_LIST ThriftType - deriving ( Eq, Show ) - --- NOTE: when using toEnum information about parametized types is NOT preserved. --- This design choice is consistent woth the Thrift implementation in other --- languages -instance Enum ThriftType where - fromEnum T_STOP = 0 - fromEnum T_VOID = 1 - fromEnum T_BOOL = 2 - fromEnum T_BYTE = 3 - fromEnum T_DOUBLE = 4 - fromEnum T_I16 = 6 - fromEnum T_I32 = 8 - fromEnum T_I64 = 10 - fromEnum T_STRING = 11 - fromEnum T_BINARY = 11 - fromEnum (T_STRUCT _) = 12 - fromEnum (T_MAP _ _) = 13 - fromEnum (T_SET _) = 14 - fromEnum (T_LIST _) = 15 - - toEnum 0 = T_STOP - toEnum 1 = T_VOID - toEnum 2 = T_BOOL - toEnum 3 = T_BYTE - toEnum 4 = T_DOUBLE - toEnum 6 = T_I16 - toEnum 8 = T_I32 - toEnum 10 = T_I64 - toEnum 11 = T_STRING - -- toEnum 11 = T_BINARY - toEnum 12 = T_STRUCT Map.empty - toEnum 13 = T_MAP T_VOID T_VOID - toEnum 14 = T_SET T_VOID - toEnum 15 = T_LIST T_VOID - toEnum t = error $ "Invalid ThriftType " ++ show t - -data MessageType - = M_CALL - | M_REPLY - | M_EXCEPTION - | M_ONEWAY - deriving ( Eq, Show ) - -instance Enum MessageType where - fromEnum M_CALL = 1 - fromEnum M_REPLY = 2 - fromEnum M_EXCEPTION = 3 - fromEnum M_ONEWAY = 4 - - toEnum 1 = M_CALL - toEnum 2 = M_REPLY - toEnum 3 = M_EXCEPTION - toEnum 4 = M_ONEWAY - toEnum t = error $ "Invalid MessageType " ++ show t - -instance Arbitrary MessageType where - arbitrary = elements [M_CALL, M_REPLY, M_EXCEPTION, M_ONEWAY] diff --git a/lib/hs/test/BinarySpec.hs b/lib/hs/test/BinarySpec.hs deleted file mode 100644 index d692fabe3..000000000 --- a/lib/hs/test/BinarySpec.hs +++ /dev/null @@ -1,91 +0,0 @@ --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -module BinarySpec where - -import Test.Hspec -import Test.Hspec.QuickCheck (prop) - -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as C - -import Thrift.Types -import Thrift.Transport -import Thrift.Transport.Memory -import Thrift.Protocol -import Thrift.Protocol.Binary - -spec :: Spec -spec = do - describe "BinaryProtocol" $ do - describe "double" $ do - it "writes in big endian order" $ do - let val = 2 ** 53 - trans <- openMemoryBuffer - let proto = BinaryProtocol trans - writeVal proto (TDouble val) - bin <- tRead trans 8 - (LBS.unpack bin) `shouldBe`[67, 64, 0, 0, 0, 0, 0, 0] - - it "reads in big endian order" $ do - let bin = LBS.pack [67, 64, 0, 0, 0, 0, 0, 0] - trans <- openMemoryBuffer - let proto = BinaryProtocol trans - tWrite trans bin - val <- readVal proto T_DOUBLE - val `shouldBe` (TDouble $ 2 ** 53) - - prop "round trip" $ \val -> do - trans <- openMemoryBuffer - let proto = BinaryProtocol trans - writeVal proto $ TDouble val - val2 <- readVal proto T_DOUBLE - val2 `shouldBe` (TDouble val) - - describe "string" $ do - it "writes" $ do - let val = C.pack "aaa" - trans <- openMemoryBuffer - let proto = BinaryProtocol trans - writeVal proto (TString val) - bin <- tRead trans 7 - (LBS.unpack bin) `shouldBe` [0, 0, 0, 3, 97, 97, 97] - - describe "binary" $ do - it "writes" $ do - trans <- openMemoryBuffer - let proto = BinaryProtocol trans - writeVal proto (TBinary $ LBS.pack [42, 43, 44]) - bin <- tRead trans 100 - (LBS.unpack bin) `shouldBe` [0, 0, 0, 3, 42, 43, 44] - - it "reads" $ do - trans <- openMemoryBuffer - let proto = BinaryProtocol trans - tWrite trans $ LBS.pack [0, 0, 0, 3, 42, 43, 44] - val <- readVal proto (T_BINARY) - val `shouldBe` (TBinary $ LBS.pack [42, 43, 44]) - - prop "round trip" $ \val -> do - trans <- openMemoryBuffer - let proto = BinaryProtocol trans - writeVal proto (TBinary $ LBS.pack val) - val2 <- readVal proto (T_BINARY) - val2 `shouldBe` (TBinary $ LBS.pack val) - diff --git a/lib/hs/test/CompactSpec.hs b/lib/hs/test/CompactSpec.hs deleted file mode 100644 index 5540e7b5e..000000000 --- a/lib/hs/test/CompactSpec.hs +++ /dev/null @@ -1,81 +0,0 @@ --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -module CompactSpec where - -import Test.Hspec -import Test.Hspec.QuickCheck (prop) - -import qualified Data.ByteString.Lazy as LBS - -import Thrift.Types -import Thrift.Transport -import Thrift.Transport.Memory -import Thrift.Protocol -import Thrift.Protocol.Compact - -spec :: Spec -spec = do - describe "CompactProtocol" $ do - describe "double" $ do - it "writes in little endian order" $ do - let val = 2 ** 53 - trans <- openMemoryBuffer - let proto = CompactProtocol trans - writeVal proto (TDouble val) - bin <- tReadAll trans 8 - (LBS.unpack bin) `shouldBe`[0, 0, 0, 0, 0, 0, 64, 67] - - it "reads in little endian order" $ do - let bin = LBS.pack [0, 0, 0, 0, 0, 0, 64, 67] - trans <- openMemoryBuffer - let proto = CompactProtocol trans - tWrite trans bin - val <- readVal proto T_DOUBLE - val `shouldBe` (TDouble $ 2 ** 53) - - prop "round trip" $ \val -> do - trans <- openMemoryBuffer - let proto = CompactProtocol trans - writeVal proto $ TDouble val - val2 <- readVal proto T_DOUBLE - val2 `shouldBe` (TDouble val) - - describe "binary" $ do - it "writes" $ do - trans <- openMemoryBuffer - let proto = CompactProtocol trans - writeVal proto (TBinary $ LBS.pack [42, 43, 44]) - bin <- tRead trans 100 - (LBS.unpack bin) `shouldBe` [3, 42, 43, 44] - - it "reads" $ do - trans <- openMemoryBuffer - let proto = CompactProtocol trans - tWrite trans $ LBS.pack [3, 42, 43, 44] - val <- readVal proto (T_BINARY) - val `shouldBe` (TBinary $ LBS.pack [42, 43, 44]) - - prop "round trip" $ \val -> do - trans <- openMemoryBuffer - let proto = CompactProtocol trans - writeVal proto (TBinary $ LBS.pack val) - val2 <- readVal proto (T_BINARY) - val2 `shouldBe` (TBinary $ LBS.pack val) - diff --git a/lib/hs/test/JSONSpec.hs b/lib/hs/test/JSONSpec.hs deleted file mode 100644 index 022c8265e..000000000 --- a/lib/hs/test/JSONSpec.hs +++ /dev/null @@ -1,225 +0,0 @@ --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -module JSONSpec where - -import Test.Hspec -import Test.Hspec.QuickCheck (prop) - -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as C - -import Thrift.Types -import Thrift.Transport -import Thrift.Transport.Memory -import Thrift.Protocol -import Thrift.Protocol.JSON - -tString :: [Char] -> ThriftVal -tString = TString . C.pack - -spec :: Spec -spec = do - describe "JSONProtocol" $ do - describe "bool" $ do - it "writes true as 1" $ do - let val = True - trans <- openMemoryBuffer - let proto = JSONProtocol trans - writeVal proto (TBool val) - bin <-tRead trans 100 - (C.unpack bin) `shouldBe` ['1'] - - it "writes false as 0" $ do - let val = False - trans <- openMemoryBuffer - let proto = JSONProtocol trans - writeVal proto (TBool val) - bin <- tRead trans 100 - (C.unpack bin) `shouldBe` ['0'] - - prop "round trip" $ \val -> do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - writeVal proto $ TBool val - val2 <- readVal proto T_BOOL - val2 `shouldBe` (TBool val) - - describe "string" $ do - it "writes" $ do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - writeVal proto (TString $ C.pack "\"a") - bin <- tRead trans 100 - (C.unpack bin) `shouldBe` "\"\\\"a\"" - - it "reads" $ do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - tWrite trans $ C.pack "\"\\\"a\"" - val <- readVal proto (T_STRING) - val `shouldBe` (TString $ C.pack "\"a") - - prop "round trip" $ \val -> do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - writeVal proto (TString $ C.pack val) - val2 <- readVal proto (T_STRING) - val2 `shouldBe` (TString $ C.pack val) - - describe "binary" $ do - it "writes with padding" $ do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - writeVal proto (TBinary $ LBS.pack [1]) - bin <- tRead trans 100 - (C.unpack bin) `shouldBe` "\"AQ==\"" - - it "reads with padding" $ do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - tWrite trans $ C.pack "\"AQ==\"" - val <- readVal proto (T_BINARY) - val `shouldBe` (TBinary $ LBS.pack [1]) - - it "reads without padding" $ do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - tWrite trans $ C.pack "\"AQ\"" - val <- readVal proto (T_BINARY) - val `shouldBe` (TBinary $ LBS.pack [1]) - - prop "round trip" $ \val -> do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - writeVal proto (TBinary $ LBS.pack val) - val2 <- readVal proto (T_BINARY) - val2 `shouldBe` (TBinary $ LBS.pack val) - - describe "list" $ do - it "writes empty list" $ do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - writeVal proto (TList T_BYTE []) - bin <- tRead trans 100 - (C.unpack bin) `shouldBe` "[\"i8\",0]" - - it "reads empty" $ do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - tWrite trans (C.pack "[\"i8\",0]") - val <- readVal proto (T_LIST T_BYTE) - val `shouldBe` (TList T_BYTE []) - - it "writes single element" $ do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - writeVal proto (TList T_BYTE [TByte 0]) - bin <- tRead trans 100 - (C.unpack bin) `shouldBe` "[\"i8\",1,0]" - - it "reads single element" $ do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - tWrite trans (C.pack "[\"i8\",1,0]") - val <- readVal proto (T_LIST T_BYTE) - val `shouldBe` (TList T_BYTE [TByte 0]) - - it "reads elements" $ do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - tWrite trans (C.pack "[\"i8\",2,42, 43]") - val <- readVal proto (T_LIST T_BYTE) - val `shouldBe` (TList T_BYTE [TByte 42, TByte 43]) - - prop "round trip" $ \val -> do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - writeVal proto $ (TList T_STRING $ map tString val) - val2 <- readVal proto $ T_LIST T_STRING - val2 `shouldBe` (TList T_STRING $ map tString val) - - describe "set" $ do - it "writes empty" $ do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - writeVal proto (TSet T_BYTE []) - bin <- tRead trans 100 - (C.unpack bin) `shouldBe` "[\"i8\",0]" - - it "reads empty" $ do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - tWrite trans (C.pack "[\"i8\",0]") - val <- readVal proto (T_SET T_BYTE) - val `shouldBe` (TSet T_BYTE []) - - it "reads single element" $ do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - tWrite trans (C.pack "[\"i8\",1,0]") - val <- readVal proto (T_SET T_BYTE) - val `shouldBe` (TSet T_BYTE [TByte 0]) - - it "reads elements" $ do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - tWrite trans (C.pack "[\"i8\",2,42, 43]") - val <- readVal proto (T_SET T_BYTE) - val `shouldBe` (TSet T_BYTE [TByte 42, TByte 43]) - - prop "round trip" $ \val -> do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - writeVal proto $ (TSet T_STRING $ map tString val) - val2 <- readVal proto $ T_SET T_STRING - val2 `shouldBe` (TSet T_STRING $ map tString val) - - describe "map" $ do - it "writes empty" $ do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - writeVal proto (TMap T_BYTE T_BYTE []) - bin <- tRead trans 100 - (C.unpack bin) `shouldBe`"[\"i8\",\"i8\",0,{}]" - - it "reads empty" $ do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - tWrite trans (C.pack "[\"i8\",\"i8\",0,{}]") - val <- readVal proto (T_MAP T_BYTE T_BYTE) - val `shouldBe` (TMap T_BYTE T_BYTE []) - - it "reads string-string" $ do - let bin = "[\"str\",\"str\",2,{\"a\":\"2\",\"b\":\"blah\"}]" - trans <- openMemoryBuffer - let proto = JSONProtocol trans - tWrite trans (C.pack bin) - val <- readVal proto (T_MAP T_STRING T_STRING) - val`shouldBe` (TMap T_STRING T_STRING [(tString "a", tString "2"), (tString "b", tString "blah")]) - - prop "round trip" $ \val -> do - trans <- openMemoryBuffer - let proto = JSONProtocol trans - writeVal proto $ (TMap T_STRING T_STRING $ map toKV val) - val2 <- readVal proto $ T_MAP T_STRING T_STRING - val2 `shouldBe` (TMap T_STRING T_STRING $ map toKV val) - where - toKV v = (tString v, tString v) - diff --git a/lib/hs/test/Spec.hs b/lib/hs/test/Spec.hs deleted file mode 100644 index 7ec9a990b..000000000 --- a/lib/hs/test/Spec.hs +++ /dev/null @@ -1,38 +0,0 @@ --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - --- Our CI does not work well with auto discover. --- Need to add build-time PATH variable to hspec-discover dir from CMake --- or install hspec system-wide for the following to work. --- {-# OPTIONS_GHC -F -pgmF hspec-discover #-} - -import Test.Hspec - -import qualified BinarySpec -import qualified CompactSpec -import qualified JSONSpec - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "Binary" BinarySpec.spec - describe "Compact" CompactSpec.spec - describe "JSON" JSONSpec.spec diff --git a/lib/hs/thrift.cabal b/lib/hs/thrift.cabal deleted file mode 100644 index 5c3d37ad9..000000000 --- a/lib/hs/thrift.cabal +++ /dev/null @@ -1,84 +0,0 @@ --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -Name: thrift -Version: 0.15.0 -Cabal-Version: 1.24 -License: Apache -Category: Foreign -Build-Type: Simple -Synopsis: Haskell bindings for the Apache Thrift RPC system -Homepage: http://thrift.apache.org -Bug-Reports: https://issues.apache.org/jira/browse/THRIFT -Maintainer: dev@thrift.apache.org -License-File: LICENSE - -Description: - Haskell bindings for the Apache Thrift RPC system. Requires the use of the thrift code generator. - -flag network-uri - description: Get Network.URI from the network-uri package - default: True - -Library - Hs-Source-Dirs: - src - Build-Depends: - base >= 4, base < 5, containers, ghc-prim, attoparsec, binary, bytestring >= 0.10, base64-bytestring, hashable, HTTP, text, hspec-core > 2.4.0, unordered-containers >= 0.2.6, vector >= 0.10.12.2, QuickCheck >= 2.8.2, split - if flag(network-uri) - build-depends: network-uri >= 2.6, network >= 2.6 && < 3.0 - else - build-depends: network < 2.6 - Exposed-Modules: - Thrift, - Thrift.Arbitraries - Thrift.Protocol, - Thrift.Protocol.Header, - Thrift.Protocol.Binary, - Thrift.Protocol.Compact, - Thrift.Protocol.JSON, - Thrift.Server, - Thrift.Transport, - Thrift.Transport.Empty, - Thrift.Transport.Framed, - Thrift.Transport.Handle, - Thrift.Transport.Header, - Thrift.Transport.HttpClient, - Thrift.Transport.IOBuffer, - Thrift.Transport.Memory, - Thrift.Types - Default-Language: Haskell2010 - Default-Extensions: - DeriveDataTypeable, - ExistentialQuantification, - FlexibleInstances, - KindSignatures, - MagicHash, - RankNTypes, - RecordWildCards, - ScopedTypeVariables, - TypeSynonymInstances - -Test-Suite spec - Type: exitcode-stdio-1.0 - Hs-Source-Dirs: test - Ghc-Options: -Wall - main-is: Spec.hs - Build-Depends: base, thrift, hspec, QuickCheck >= 2.8.2, bytestring >= 0.10, unordered-containers >= 0.2.6 - Default-Language: Haskell2010 diff --git a/test/Makefile.am b/test/Makefile.am index 4ef12e06a..15e2f1bcc 100755 --- a/test/Makefile.am +++ b/test/Makefile.am @@ -64,10 +64,6 @@ SUBDIRS += rb PRECROSS_TARGET += precross-rb endif -if WITH_HASKELL -SUBDIRS += hs -endif - if WITH_HAXE SUBDIRS += haxe endif @@ -127,7 +123,6 @@ EXTRA_DIST = \ crossrunner \ dart \ erl \ - hs \ keys \ lua \ ocaml \ diff --git a/test/hs/CMakeLists.txt b/test/hs/CMakeLists.txt deleted file mode 100644 index eaca3fa04..000000000 --- a/test/hs/CMakeLists.txt +++ /dev/null @@ -1,114 +0,0 @@ -# -# Licensed to the Apache Software Foundation (ASF) under one -# or more contributor license agreements. See the NOTICE file -# distributed with this work for additional information -# regarding copyright ownership. The ASF licenses this file -# to you under the Apache License, Version 2.0 (the -# "License"); you may not use this file except in compliance -# with the License. You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, -# software distributed under the License is distributed on an -# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -# KIND, either express or implied. See the License for the -# specific language governing permissions and limitations -# under the License. -# - -set(hs_test_gen - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/ConstantsDemo_Consts.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/ConstantsDemo_Types.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/DebugProtoTest_Consts.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/DebugProtoTest_Types.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/EmptyService_Client.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/EmptyService.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/EmptyService_Iface.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/Include_Consts.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/Include_Types.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/Inherited_Client.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/Inherited.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/Inherited_Iface.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/ReverseOrderService_Client.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/ReverseOrderService.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/ReverseOrderService_Iface.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/SecondService_Client.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/SecondService.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/SecondService_Iface.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/ServiceForExceptionWithAMap_Client.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/ServiceForExceptionWithAMap.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/ServiceForExceptionWithAMap_Iface.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/Srv_Client.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/Srv.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/Srv_Iface.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/ThriftTest_Client.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/ThriftTest_Consts.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/ThriftTest.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/ThriftTest_Iface.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/ThriftTest_Types.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/Yowza_Client.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/Yowza.hs - ${CMAKE_CURRENT_BINARY_DIR}/gen-hs/Yowza_Iface.hs -) - -set(hs_crosstest_apps - ${CMAKE_CURRENT_BINARY_DIR}/TestServer - ${CMAKE_CURRENT_BINARY_DIR}/TestClient -) -set(hs_crosstest_args - -igen-hs - -odir=${CMAKE_CURRENT_BINARY_DIR} - -hidir=${CMAKE_CURRENT_BINARY_DIR} -) - -if (CMAKE_BUILD_TYPE STREQUAL "Debug") - set(hs_optimize -O0) -else() - set(hs_optimize -O1) -endif() - -add_custom_command( - OUTPUT ${hs_crosstest_apps} - COMMAND ${GHC} ${hs_optimize} ${hs_crosstest_args} ${CMAKE_CURRENT_SOURCE_DIR}/TestServer.hs -o TestServer - COMMAND ${GHC} ${hs_optimize} ${hs_crosstest_args} ${CMAKE_CURRENT_SOURCE_DIR}/TestClient.hs -o TestClient - DEPENDS ${hs_test_gen} haskell_library TestServer.hs TestClient.hs -) -add_custom_target(haskell_crosstest ALL - COMMENT "Building Haskell cross test executables" - DEPENDS ${hs_crosstest_apps} -) - -set(hs_test_sources - ConstantsDemo_Main.hs - DebugProtoTest_Main.hs - Include_Main.hs - ThriftTest_Main.hs -) -set(hs_test_args - -Wall - -XScopedTypeVariables - -i${PROJECT_SOURCE_DIR}/lib/hs/src - -i${CMAKE_CURRENT_BINARY_DIR}/gen-hs -) -add_custom_target(haskell_tests ALL DEPENDS ${hs_test_gen}) -foreach(SRC ${hs_test_sources}) - get_filename_component(BASE ${SRC} NAME_WE) - add_test(NAME HaskellTests-${BASE} - COMMAND ${RUN_HASKELL} ${hs_test_args} ${SRC} - WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) -endforeach() - -set(hs_test_gen_sources - ${PROJECT_SOURCE_DIR}/test/ConstantsDemo.thrift - ${PROJECT_SOURCE_DIR}/test/DebugProtoTest.thrift - ${PROJECT_SOURCE_DIR}/test/ThriftTest.thrift - ${PROJECT_SOURCE_DIR}/test/Include.thrift -) -add_custom_command(OUTPUT ${hs_test_gen} - COMMAND ${THRIFT_COMPILER} --gen hs ${PROJECT_SOURCE_DIR}/test/ConstantsDemo.thrift - COMMAND ${THRIFT_COMPILER} --gen hs ${PROJECT_SOURCE_DIR}/test/DebugProtoTest.thrift - COMMAND ${THRIFT_COMPILER} --gen hs ${PROJECT_SOURCE_DIR}/test/ThriftTest.thrift - COMMAND ${THRIFT_COMPILER} --gen hs ${PROJECT_SOURCE_DIR}/test/Include.thrift - DEPENDS ${hs_test_gen_sources} -) diff --git a/test/hs/ConstantsDemo_Main.hs b/test/hs/ConstantsDemo_Main.hs deleted file mode 100644 index 28de4f7ea..000000000 --- a/test/hs/ConstantsDemo_Main.hs +++ /dev/null @@ -1,68 +0,0 @@ --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -module Main where - - -import qualified Control.Exception -import qualified Network - -import Thrift.Protocol.Binary -import Thrift.Server -import Thrift.Transport.Handle - -import qualified ThriftTestUtils - -import qualified Yowza -import qualified Yowza_Client as Client -import qualified Yowza_Iface as Iface - - -data YowzaHandler = YowzaHandler -instance Iface.Yowza_Iface YowzaHandler where - blingity _ = do - ThriftTestUtils.serverLog "SERVER: Got blingity" - return () - - blangity _ = do - ThriftTestUtils.serverLog "SERVER: Got blangity" - return $ 31 - - -client :: (String, Network.PortID) -> IO () -client addr = do - to <- hOpen addr - let ps = (BinaryProtocol to, BinaryProtocol to) - - Client.blingity ps - - rv <- Client.blangity ps - ThriftTestUtils.clientLog $ show rv - - tClose to - -server :: Network.PortNumber -> IO () -server port = do - ThriftTestUtils.serverLog "Ready..." - (runBasicServer YowzaHandler Yowza.process port) - `Control.Exception.catch` - (\(TransportExn s _) -> error $ "FAILURE: " ++ show s) - -main :: IO () -main = ThriftTestUtils.runTest server client diff --git a/test/hs/DebugProtoTest_Main.hs b/test/hs/DebugProtoTest_Main.hs deleted file mode 100644 index 97d4347c2..000000000 --- a/test/hs/DebugProtoTest_Main.hs +++ /dev/null @@ -1,172 +0,0 @@ --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -{-# LANGUAGE OverloadedStrings #-} - -module Main where - - -import qualified Control.Exception -import qualified Data.ByteString.Lazy as DBL -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import qualified Data.Vector as Vector -import qualified Network - -import Thrift.Protocol.Binary -import Thrift.Server -import Thrift.Transport.Handle - -import qualified ThriftTestUtils - -import qualified DebugProtoTest_Types as Types -import qualified Inherited -import qualified Inherited_Client as IClient -import qualified Inherited_Iface as IIface -import qualified Srv_Client as SClient -import qualified Srv_Iface as SIface - --- we don't actually need this import, but force it to check the code generator exports proper Haskell syntax -import qualified Srv() - - -data InheritedHandler = InheritedHandler -instance SIface.Srv_Iface InheritedHandler where - janky _ arg = do - ThriftTestUtils.serverLog $ "Got janky method call: " ++ show arg - return $ 31 - - voidMethod _ = do - ThriftTestUtils.serverLog "Got voidMethod method call" - return () - - primitiveMethod _ = do - ThriftTestUtils.serverLog "Got primitiveMethod call" - return $ 42 - - structMethod _ = do - ThriftTestUtils.serverLog "Got structMethod call" - return $ Types.CompactProtoTestStruct { - Types.compactProtoTestStruct_a_byte = 0x01, - Types.compactProtoTestStruct_a_i16 = 0x02, - Types.compactProtoTestStruct_a_i32 = 0x03, - Types.compactProtoTestStruct_a_i64 = 0x04, - Types.compactProtoTestStruct_a_double = 0.1, - Types.compactProtoTestStruct_a_string = "abcdef", - Types.compactProtoTestStruct_a_binary = DBL.empty, - Types.compactProtoTestStruct_true_field = True, - Types.compactProtoTestStruct_false_field = False, - Types.compactProtoTestStruct_empty_struct_field = Types.Empty, - - Types.compactProtoTestStruct_byte_list = Vector.empty, - Types.compactProtoTestStruct_i16_list = Vector.empty, - Types.compactProtoTestStruct_i32_list = Vector.empty, - Types.compactProtoTestStruct_i64_list = Vector.empty, - Types.compactProtoTestStruct_double_list = Vector.empty, - Types.compactProtoTestStruct_string_list = Vector.empty, - Types.compactProtoTestStruct_binary_list = Vector.empty, - Types.compactProtoTestStruct_boolean_list = Vector.empty, - Types.compactProtoTestStruct_struct_list = Vector.empty, - - Types.compactProtoTestStruct_byte_set = Set.empty, - Types.compactProtoTestStruct_i16_set = Set.empty, - Types.compactProtoTestStruct_i32_set = Set.empty, - Types.compactProtoTestStruct_i64_set = Set.empty, - Types.compactProtoTestStruct_double_set = Set.empty, - Types.compactProtoTestStruct_string_set = Set.empty, - Types.compactProtoTestStruct_binary_set = Set.empty, - Types.compactProtoTestStruct_boolean_set = Set.empty, - Types.compactProtoTestStruct_struct_set = Set.empty, - - Types.compactProtoTestStruct_byte_byte_map = Map.empty, - Types.compactProtoTestStruct_i16_byte_map = Map.empty, - Types.compactProtoTestStruct_i32_byte_map = Map.empty, - Types.compactProtoTestStruct_i64_byte_map = Map.empty, - Types.compactProtoTestStruct_double_byte_map = Map.empty, - Types.compactProtoTestStruct_string_byte_map = Map.empty, - Types.compactProtoTestStruct_binary_byte_map = Map.empty, - Types.compactProtoTestStruct_boolean_byte_map = Map.empty, - - Types.compactProtoTestStruct_byte_i16_map = Map.empty, - Types.compactProtoTestStruct_byte_i32_map = Map.empty, - Types.compactProtoTestStruct_byte_i64_map = Map.empty, - Types.compactProtoTestStruct_byte_double_map = Map.empty, - Types.compactProtoTestStruct_byte_string_map = Map.empty, - Types.compactProtoTestStruct_byte_binary_map = Map.empty, - Types.compactProtoTestStruct_byte_boolean_map = Map.empty, - - Types.compactProtoTestStruct_list_byte_map = Map.empty, - Types.compactProtoTestStruct_set_byte_map = Map.empty, - Types.compactProtoTestStruct_map_byte_map = Map.empty, - - Types.compactProtoTestStruct_byte_map_map = Map.empty, - Types.compactProtoTestStruct_byte_set_map = Map.empty, - Types.compactProtoTestStruct_byte_list_map = Map.empty, - - Types.compactProtoTestStruct_field500 = 500, - Types.compactProtoTestStruct_field5000 = 5000, - Types.compactProtoTestStruct_field20000 = 20000 } - - methodWithDefaultArgs _ arg = do - ThriftTestUtils.serverLog $ "Got methodWithDefaultArgs: " ++ show arg - return () - - onewayMethod _ = do - ThriftTestUtils.serverLog "Got onewayMethod" - -instance IIface.Inherited_Iface InheritedHandler where - identity _ arg = do - ThriftTestUtils.serverLog $ "Got identity method: " ++ show arg - return arg - -client :: (String, Network.PortID) -> IO () -client addr = do - to <- hOpen addr - let p = BinaryProtocol to - let ps = (p,p) - - v1 <- SClient.janky ps 42 - ThriftTestUtils.clientLog $ show v1 - - SClient.voidMethod ps - - v2 <- SClient.primitiveMethod ps - ThriftTestUtils.clientLog $ show v2 - - v3 <- SClient.structMethod ps - ThriftTestUtils.clientLog $ show v3 - - SClient.methodWithDefaultArgs ps 42 - - SClient.onewayMethod ps - - v4 <- IClient.identity ps 42 - ThriftTestUtils.clientLog $ show v4 - - return () - -server :: Network.PortNumber -> IO () -server port = do - ThriftTestUtils.serverLog "Ready..." - (runBasicServer InheritedHandler Inherited.process port) - `Control.Exception.catch` - (\(TransportExn s _) -> error $ "FAILURE: " ++ show s) - -main :: IO () -main = ThriftTestUtils.runTest server client diff --git a/test/hs/Include_Main.hs b/test/hs/Include_Main.hs deleted file mode 100644 index d3977a157..000000000 --- a/test/hs/Include_Main.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Main where - -import Include_Types -import ThriftTest_Types - -main :: IO () -main = putStrLn ("Includes work: " ++ (show (IncludeTest $ Bools True False))) diff --git a/test/hs/Makefile.am b/test/hs/Makefile.am deleted file mode 100644 index 817070d8f..000000000 --- a/test/hs/Makefile.am +++ /dev/null @@ -1,50 +0,0 @@ -# -# Licensed to the Apache Software Foundation (ASF) under one -# or more contributor license agreements. See the NOTICE file -# distributed with this work for additional information -# regarding copyright ownership. The ASF licenses this file -# to you under the Apache License, Version 2.0 (the -# "License"); you may not use this file except in compliance -# with the License. You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, -# software distributed under the License is distributed on an -# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -# KIND, either express or implied. See the License for the -# specific language governing permissions and limitations -# under the License. -# - -stubs: $(THRIFT) ../ConstantsDemo.thrift ../DebugProtoTest.thrift ../ThriftTest.thrift ../Include.thrift - $(THRIFT) --gen hs ../ConstantsDemo.thrift - $(THRIFT) --gen hs ../DebugProtoTest.thrift - $(THRIFT) --gen hs ../ThriftTest.thrift - $(THRIFT) --gen hs ../Include.thrift - -check: stubs - sh run-test.sh ConstantsDemo - sh run-test.sh DebugProtoTest - sh run-test.sh ThriftTest - sh run-test.sh Include - -clean-local: - $(RM) -r gen-hs/ - $(RM) *.hi - $(RM) *.o - $(RM) TestClient - $(RM) TestServer - -dist-hook: - $(RM) -r $(distdir)/gen-hs/ - $(RM) $(distdir)/*.hi - $(RM) $(distdir)/*.o - $(RM) $(destdir)/TestClient - $(RM) $(destdir)/TestServer - -all-local: stubs - ghc -igen-hs TestServer.hs - ghc -igen-hs TestClient.hs - -precross: all-local diff --git a/test/hs/TestClient.hs b/test/hs/TestClient.hs deleted file mode 100644 index d014e089a..000000000 --- a/test/hs/TestClient.hs +++ /dev/null @@ -1,306 +0,0 @@ --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -{-# LANGUAGE OverloadedStrings, RecordWildCards, ScopedTypeVariables #-} -module Main where - -import Control.Exception -import Control.Monad -import Data.Functor -import Data.List.Split -import Data.String -import Network -import Network.URI -import System.Environment -import System.Exit -import qualified Data.ByteString.Lazy as LBS -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import qualified Data.Vector as Vector -import qualified System.IO as IO - -import ThriftTest_Iface -import ThriftTest_Types -import qualified ThriftTest_Client as Client - -import Thrift.Transport -import Thrift.Transport.Framed -import Thrift.Transport.Handle -import Thrift.Transport.HttpClient -import Thrift.Protocol -import Thrift.Protocol.Binary -import Thrift.Protocol.Compact -import Thrift.Protocol.Header -import Thrift.Protocol.JSON - -data Options = Options - { host :: String - , port :: Int - , domainSocket :: String - , transport :: String - , protocol :: ProtocolType - -- TODO: Haskell lib does not have SSL support - , ssl :: Bool - , testLoops :: Int - } - deriving (Show, Eq) - -data TransportType = Buffered IO.Handle - | Framed (FramedTransport IO.Handle) - | Http HttpClient - | NoTransport String - -getTransport :: String -> String -> Int -> (IO TransportType) -getTransport "buffered" host port = do - h <- hOpen (host, PortNumber $ fromIntegral port) - IO.hSetBuffering h $ IO.BlockBuffering Nothing - return $ Buffered h -getTransport "framed" host port = do - h <- hOpen (host, PortNumber $ fromIntegral port) - t <- openFramedTransport h - return $ Framed t -getTransport "http" host port = let uriStr = "http://" ++ host ++ ":" ++ show port in - case parseURI uriStr of - Nothing -> do return (NoTransport $ "Failed to parse URI: " ++ uriStr) - Just(uri) -> do - t <- openHttpClient uri - return $ Http t -getTransport t host port = do return (NoTransport $ "Unsupported transport: " ++ t) - -data ProtocolType = Binary - | Compact - | JSON - | Header - deriving (Show, Eq) - -getProtocol :: String -> ProtocolType -getProtocol "binary" = Binary -getProtocol "compact" = Compact -getProtocol "json" = JSON -getProtocol "header" = Header -getProtocol p = error $ "Unsupported Protocol: " ++ p - -defaultOptions :: Options -defaultOptions = Options - { port = 9090 - , domainSocket = "" - , host = "localhost" - , transport = "buffered" - , protocol = Binary - , ssl = False - , testLoops = 1 - } - -runClient :: Protocol p => p -> IO () -runClient p = do - let prot = (p,p) - putStrLn "Starting Tests" - - -- VOID Test - putStrLn "testVoid" - Client.testVoid prot - - -- String Test - putStrLn "testString" - s <- Client.testString prot "Test" - when (s /= "Test") exitFailure - - -- Bool Test - putStrLn "testBool" - bool <- Client.testBool prot True - when (not bool) exitFailure - putStrLn "testBool" - bool <- Client.testBool prot False - when (bool) exitFailure - - -- Byte Test - putStrLn "testByte" - byte <- Client.testByte prot 1 - when (byte /= 1) exitFailure - - -- I32 Test - putStrLn "testI32" - i32 <- Client.testI32 prot (-1) - when (i32 /= -1) exitFailure - - -- I64 Test - putStrLn "testI64" - i64 <- Client.testI64 prot (-34359738368) - when (i64 /= -34359738368) exitFailure - - -- Double Test - putStrLn "testDouble" - dub <- Client.testDouble prot (-5.2098523) - when (abs (dub + 5.2098523) > 0.001) exitFailure - - -- Binary Test - putStrLn "testBinary" - bin <- Client.testBinary prot (LBS.pack . reverse $ [-128..127]) - when ((reverse [-128..127]) /= LBS.unpack bin) exitFailure - - -- Struct Test - let structIn = Xtruct{ xtruct_string_thing = "Zero" - , xtruct_byte_thing = 1 - , xtruct_i32_thing = -3 - , xtruct_i64_thing = -5 - } - putStrLn "testStruct" - structOut <- Client.testStruct prot structIn - when (structIn /= structOut) exitFailure - - -- Nested Struct Test - let nestIn = Xtruct2{ xtruct2_byte_thing = 1 - , xtruct2_struct_thing = structIn - , xtruct2_i32_thing = 5 - } - putStrLn "testNest" - nestOut <- Client.testNest prot nestIn - when (nestIn /= nestOut) exitFailure - - -- Map Test - let mapIn = Map.fromList $ map (\i -> (i, i-10)) [1..5] - putStrLn "testMap" - mapOut <- Client.testMap prot mapIn - when (mapIn /= mapOut) exitFailure - - -- Set Test - let setIn = Set.fromList [-2..3] - putStrLn "testSet" - setOut <- Client.testSet prot setIn - when (setIn /= setOut) exitFailure - - -- List Test - let listIn = Vector.fromList [-2..3] - putStrLn "testList" - listOut <- Client.testList prot listIn - when (listIn /= listOut) exitFailure - - -- Enum Test - putStrLn "testEnum" - numz1 <- Client.testEnum prot Numberz_ONE - when (numz1 /= Numberz_ONE) exitFailure - - putStrLn "testEnum" - numz2 <- Client.testEnum prot Numberz_TWO - when (numz2 /= Numberz_TWO) exitFailure - - putStrLn "testEnum" - numz5 <- Client.testEnum prot Numberz_FIVE - when (numz5 /= Numberz_FIVE) exitFailure - - -- Typedef Test - putStrLn "testTypedef" - uid <- Client.testTypedef prot 309858235082523 - when (uid /= 309858235082523) exitFailure - - -- Nested Map Test - putStrLn "testMapMap" - _ <- Client.testMapMap prot 1 - - -- Exception Test - putStrLn "testException" - exn1 <- try $ Client.testException prot "Xception" - case exn1 of - Left (Xception _ _) -> return () - _ -> putStrLn (show exn1) >> exitFailure - - putStrLn "testException" - exn2 <- try $ Client.testException prot "TException" - case exn2 of - Left (_ :: SomeException) -> return () - Right _ -> exitFailure - - putStrLn "testException" - exn3 <- try $ Client.testException prot "success" - case exn3 of - Left (_ :: SomeException) -> exitFailure - Right _ -> return () - - -- Multi Exception Test - putStrLn "testMultiException" - multi1 <- try $ Client.testMultiException prot "Xception" "test 1" - case multi1 of - Left (Xception _ _) -> return () - _ -> exitFailure - - putStrLn "testMultiException" - multi2 <- try $ Client.testMultiException prot "Xception2" "test 2" - case multi2 of - Left (Xception2 _ _) -> return () - _ -> exitFailure - - putStrLn "testMultiException" - multi3 <- try $ Client.testMultiException prot "success" "test 3" - case multi3 of - Left (_ :: SomeException) -> exitFailure - Right _ -> return () - - -main :: IO () -main = do - options <- flip parseFlags defaultOptions <$> getArgs - case options of - Nothing -> showHelp - Just Options{..} -> do - trans <- Main.getTransport transport host port - case trans of - Buffered t -> runTest testLoops protocol t - Framed t -> runTest testLoops protocol t - Http t -> runTest testLoops protocol t - NoTransport err -> putStrLn err - where - makeClient p t = case p of - Binary -> runClient $ BinaryProtocol t - Compact -> runClient $ CompactProtocol t - JSON -> runClient $ JSONProtocol t - Header -> createHeaderProtocol t t >>= runClient - runTest loops p t = do - let client = makeClient p t - replicateM_ loops client - putStrLn "COMPLETED SUCCESSFULLY" - -parseFlags :: [String] -> Options -> Maybe Options -parseFlags (flag : flags) opts = do - let pieces = splitOn "=" flag - case pieces of - "--port" : arg : _ -> parseFlags flags opts{ port = read arg } - "--domain-socket" : arg : _ -> parseFlags flags opts{ domainSocket = read arg } - "--host" : arg : _ -> parseFlags flags opts{ host = arg } - "--transport" : arg : _ -> parseFlags flags opts{ transport = arg } - "--protocol" : arg : _ -> parseFlags flags opts{ protocol = getProtocol arg } - "-n" : arg : _ -> parseFlags flags opts{ testLoops = read arg } - "--h" : _ -> Nothing - "--help" : _ -> Nothing - "--ssl" : _ -> parseFlags flags opts{ ssl = True } - "--processor-events" : _ -> parseFlags flags opts - _ -> Nothing -parseFlags [] opts = Just opts - -showHelp :: IO () -showHelp = putStrLn - "Allowed options:\n\ - \ -h [ --help ] produce help message\n\ - \ --host arg (=localhost) Host to connect\n\ - \ --port arg (=9090) Port number to connect\n\ - \ --domain-socket arg Domain Socket (e.g. /tmp/ThriftTest.thrift),\n\ - \ instead of host and port\n\ - \ --transport arg (=buffered) Transport: buffered, framed, http\n\ - \ --protocol arg (=binary) Protocol: binary, compact, json\n\ - \ --ssl Encrypted Transport using SSL\n\ - \ -n [ --testloops ] arg (=1) Number of Tests" diff --git a/test/hs/TestServer.hs b/test/hs/TestServer.hs deleted file mode 100644 index c37dda315..000000000 --- a/test/hs/TestServer.hs +++ /dev/null @@ -1,312 +0,0 @@ --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -{-# LANGUAGE OverloadedStrings,RecordWildCards #-} -module Main where - -import Control.Exception -import Control.Monad -import Data.Functor -import Data.HashMap.Strict (HashMap) -import Data.List -import Data.List.Split -import Data.String -import Network -import System.Environment -import System.Exit -import System.IO -import Control.Concurrent (threadDelay) -import qualified System.IO as IO -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import qualified Data.Text.Lazy as Text -import qualified Data.Vector as Vector - -import ThriftTest -import ThriftTest_Iface -import ThriftTest_Types - -import Thrift -import Thrift.Server -import Thrift.Transport.Framed -import Thrift.Transport.Handle -import Thrift.Protocol.Binary -import Thrift.Protocol.Compact -import Thrift.Protocol.Header -import Thrift.Protocol.JSON - -data Options = Options - { port :: Int - , domainSocket :: String - , serverType :: ServerType - , transport :: String - , protocol :: ProtocolType - , ssl :: Bool - , workers :: Int - } - -data ServerType = Simple - | ThreadPool - | Threaded - | NonBlocking - deriving (Show, Eq) - -instance IsString ServerType where - fromString "simple" = Simple - fromString "thread-pool" = ThreadPool - fromString "threaded" = Threaded - fromString "nonblocking" = NonBlocking - fromString _ = error "not a valid server type" - -data TransportType = Buffered (Socket -> (IO IO.Handle)) - | Framed (Socket -> (IO (FramedTransport IO.Handle))) - | NoTransport String - -getTransport :: String -> TransportType -getTransport "buffered" = Buffered $ \s -> do - (h, _, _) <- (accept s) - IO.hSetBuffering h $ IO.BlockBuffering Nothing - return h -getTransport "framed" = Framed $ \s -> do - (h, _, _) <- (accept s) - openFramedTransport h -getTransport t = NoTransport $ "Unsupported transport: " ++ t - -data ProtocolType = Binary - | Compact - | JSON - | Header - -getProtocol :: String -> ProtocolType -getProtocol "binary" = Binary -getProtocol "compact" = Compact -getProtocol "json" = JSON -getProtocol "header" = Header -getProtocol p = error $"Unsupported Protocol: " ++ p - -defaultOptions :: Options -defaultOptions = Options - { port = 9090 - , domainSocket = "" - , serverType = Threaded - , transport = "buffered" - , protocol = Binary - -- TODO: Haskell lib does not have SSL support - , ssl = False - , workers = 4 - } - -stringifyMap :: (Show a, Show b) => Map.HashMap a b -> String -stringifyMap = Data.List.intercalate ", " . Data.List.map joinKV . Map.toList - where joinKV (k, v) = show k ++ " => " ++ show v - -stringifySet :: Show a => Set.HashSet a -> String -stringifySet = Data.List.intercalate ", " . Data.List.map show . Set.toList - -stringifyList :: Show a => Vector.Vector a -> String -stringifyList = Data.List.intercalate ", " . Data.List.map show . Vector.toList - -data TestHandler = TestHandler -instance ThriftTest_Iface TestHandler where - testVoid _ = System.IO.putStrLn "testVoid()" - - testString _ s = do - System.IO.putStrLn $ "testString(" ++ show s ++ ")" - return s - - testBool _ x = do - System.IO.putStrLn $ "testBool(" ++ show x ++ ")" - return x - - testByte _ x = do - System.IO.putStrLn $ "testByte(" ++ show x ++ ")" - return x - - testI32 _ x = do - System.IO.putStrLn $ "testI32(" ++ show x ++ ")" - return x - - testI64 _ x = do - System.IO.putStrLn $ "testI64(" ++ show x ++ ")" - return x - - testDouble _ x = do - System.IO.putStrLn $ "testDouble(" ++ show x ++ ")" - return x - - testBinary _ x = do - System.IO.putStrLn $ "testBinary(" ++ show x ++ ")" - return x - - testStruct _ struct@Xtruct{..} = do - System.IO.putStrLn $ "testStruct({" ++ show xtruct_string_thing - ++ ", " ++ show xtruct_byte_thing - ++ ", " ++ show xtruct_i32_thing - ++ ", " ++ show xtruct_i64_thing - ++ "})" - return struct - - testNest _ nest@Xtruct2{..} = do - let Xtruct{..} = xtruct2_struct_thing - System.IO.putStrLn $ "testNest({" ++ show xtruct2_byte_thing - ++ "{, " ++ show xtruct_string_thing - ++ ", " ++ show xtruct_byte_thing - ++ ", " ++ show xtruct_i32_thing - ++ ", " ++ show xtruct_i64_thing - ++ "}, " ++ show xtruct2_i32_thing - return nest - - testMap _ m = do - System.IO.putStrLn $ "testMap({" ++ stringifyMap m ++ "})" - return m - - testStringMap _ m = do - System.IO.putStrLn $ "testStringMap(" ++ stringifyMap m ++ "})" - return m - - testSet _ x = do - System.IO.putStrLn $ "testSet({" ++ stringifySet x ++ "})" - return x - - testList _ x = do - System.IO.putStrLn $ "testList(" ++ stringifyList x ++ "})" - return x - - testEnum _ x = do - System.IO.putStrLn $ "testEnum(" ++ show x ++ ")" - return x - - testTypedef _ x = do - System.IO.putStrLn $ "testTypedef(" ++ show x ++ ")" - return x - - testMapMap _ x = do - System.IO.putStrLn $ "testMapMap(" ++ show x ++ ")" - return $ Map.fromList [ (-4, Map.fromList [ (-4, -4) - , (-3, -3) - , (-2, -2) - , (-1, -1) - ]) - , (4, Map.fromList [ (1, 1) - , (2, 2) - , (3, 3) - , (4, 4) - ]) - ] - - testInsanity _ x = do - System.IO.putStrLn "testInsanity()" - return $ Map.fromList [ (1, Map.fromList [ (Numberz_TWO , x) - , (Numberz_THREE, x) - ]) - , (2, Map.fromList [ (Numberz_SIX, default_Insanity) - ]) - ] - - testMulti _ byte i32 i64 _ _ _ = do - System.IO.putStrLn "testMulti()" - return Xtruct{ xtruct_string_thing = Text.pack "Hello2" - , xtruct_byte_thing = byte - , xtruct_i32_thing = i32 - , xtruct_i64_thing = i64 - } - - testException _ s = do - System.IO.putStrLn $ "testException(" ++ show s ++ ")" - case s of - "Xception" -> throw $ Xception 1001 s - "TException" -> throw ThriftException - _ -> return () - - testMultiException _ s1 s2 = do - System.IO.putStrLn $ "testMultiException(" ++ show s1 ++ ", " ++ show s2 ++ ")" - case s1 of - "Xception" -> throw $ Xception 1001 "This is an Xception" - "Xception2" -> throw $ Xception2 2002 $ Xtruct "This is an Xception2" 0 0 0 - "TException" -> throw ThriftException - _ -> return default_Xtruct{ xtruct_string_thing = s2 } - - testOneway _ i = do - System.IO.putStrLn $ "testOneway(" ++ show i ++ "): Sleeping..." - threadDelay $ (fromIntegral i) * 1000000 - System.IO.putStrLn $ "testOneway(" ++ show i ++ "): done sleeping!" - -main :: IO () -main = do - options <- flip parseFlags defaultOptions <$> getArgs - case options of - Nothing -> showHelp - Just Options{..} -> do - case Main.getTransport transport of - Buffered f -> runServer protocol f port - Framed f -> runServer protocol f port - NoTransport err -> putStrLn err - System.IO.putStrLn $ "Starting \"" ++ show serverType ++ "\" server (" ++ - show transport ++ ") listen on: " ++ domainSocket ++ show port - where - acceptor p f socket = do - t <- f socket - return (p t, p t) - - headerAcceptor f socket = do - t <- f socket - p <- createHeaderProtocol1 t - return (p, p) - - doRunServer p f = do - runThreadedServer (acceptor p f) TestHandler ThriftTest.process . PortNumber . fromIntegral - - runServer p f port = case p of - Binary -> doRunServer BinaryProtocol f port - Compact -> doRunServer CompactProtocol f port - JSON -> doRunServer JSONProtocol f port - Header -> runThreadedServer (headerAcceptor f) TestHandler ThriftTest.process (PortNumber $ fromIntegral port) - -parseFlags :: [String] -> Options -> Maybe Options -parseFlags (flag : flags) opts = do - let pieces = splitOn "=" flag - case pieces of - "--port" : arg : _ -> parseFlags flags opts{ port = read arg } - "--domain-socket" : arg : _ -> parseFlags flags opts{ domainSocket = read arg } - "--server-type" : arg : _ -> parseFlags flags opts{ serverType = fromString arg } - "--transport" : arg : _ -> parseFlags flags opts{ transport = arg } - "--protocol" : arg : _ -> parseFlags flags opts{ protocol = getProtocol arg } - "--workers" : arg : _ -> parseFlags flags opts{ workers = read arg } - "-n" : arg : _ -> parseFlags flags opts{ workers = read arg } - "--h" : _ -> Nothing - "--help" : _ -> Nothing - "--ssl" : _ -> parseFlags flags opts{ ssl = True } - "--processor-events" : _ -> parseFlags flags opts - _ -> Nothing -parseFlags [] opts = Just opts - -showHelp :: IO () -showHelp = System.IO.putStrLn - "Allowed options:\n\ - \ -h [ --help ] produce help message\n\ - \ --port arg (=9090) Port number to listen\n\ - \ --domain-socket arg Unix Domain Socket (e.g. /tmp/ThriftTest.thrift)\n\ - \ --server-type arg (=simple) type of server, \"simple\", \"thread-pool\",\n\ - \ \"threaded\", or \"nonblocking\"\n\ - \ --transport arg (=buffered) transport: buffered, framed\n\ - \ --protocol arg (=binary) protocol: binary, compact, json\n\ - \ --ssl Encrypted Transport using SSL\n\ - \ --processor-events processor-events\n\ - \ -n [ --workers ] arg (=4) Number of thread pools workers. Only valid for\n\ - \ thread-pool server type" diff --git a/test/hs/ThriftTestUtils.hs b/test/hs/ThriftTestUtils.hs deleted file mode 100644 index 9c19b56a9..000000000 --- a/test/hs/ThriftTestUtils.hs +++ /dev/null @@ -1,65 +0,0 @@ --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -module ThriftTestUtils (ClientFunc, ServerFunc, clientLog, serverLog, testLog, runTest) where - - -import qualified Control.Concurrent -import qualified Network -import qualified System.IO - - -serverPort :: Network.PortNumber -serverPort = 9090 - -serverAddress :: (String, Network.PortID) -serverAddress = ("localhost", Network.PortNumber serverPort) - - -testLog :: String -> IO () -testLog str = do - System.IO.hPutStr System.IO.stdout $ str ++ "\n" - System.IO.hFlush System.IO.stdout - - -clientLog :: String -> IO () -clientLog str = testLog $ "CLIENT: " ++ str - -serverLog :: String -> IO () -serverLog str = testLog $ "SERVER: " ++ str - - -type ServerFunc = Network.PortNumber -> IO () -type ClientFunc = (String, Network.PortID) -> IO () - -runTest :: ServerFunc -> ClientFunc -> IO () -runTest server client = do - _ <- Control.Concurrent.forkIO (server serverPort) - - -- Fairly horrible; this does not 100% guarantees that the other thread - -- has actually opened the socket we need... but not much else we can do - -- without this, the client races the server to the socket, and wins every - -- time - Control.Concurrent.yield - Control.Concurrent.threadDelay $ 500 * 1000 -- unit is in _micro_seconds - Control.Concurrent.yield - - client serverAddress - - testLog "SUCCESS" diff --git a/test/hs/ThriftTest_Main.hs b/test/hs/ThriftTest_Main.hs deleted file mode 100644 index 6421c6aeb..000000000 --- a/test/hs/ThriftTest_Main.hs +++ /dev/null @@ -1,214 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -{-# LANGUAGE OverloadedStrings #-} - -module Main where - - -import qualified Control.Exception -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import qualified Data.Vector as Vector - -import qualified Network - -import Thrift -import Thrift.Protocol.Binary -import Thrift.Server -import Thrift.Transport.Handle - -import qualified ThriftTestUtils - -import qualified ThriftTest -import qualified ThriftTest_Client as Client -import qualified ThriftTest_Iface as Iface -import qualified ThriftTest_Types as Types - - -data TestHandler = TestHandler -instance Iface.ThriftTest_Iface TestHandler where - testVoid _ = return () - - testString _ s = do - ThriftTestUtils.serverLog $ show s - return s - - testByte _ x = do - ThriftTestUtils.serverLog $ show x - return x - - testI32 _ x = do - ThriftTestUtils.serverLog $ show x - return x - - testI64 _ x = do - ThriftTestUtils.serverLog $ show x - return x - - testDouble _ x = do - ThriftTestUtils.serverLog $ show x - return x - - testBinary _ x = do - ThriftTestUtils.serverLog $ show x - return x - - testStruct _ x = do - ThriftTestUtils.serverLog $ show x - return x - - testNest _ x = do - ThriftTestUtils.serverLog $ show x - return x - - testMap _ x = do - ThriftTestUtils.serverLog $ show x - return x - - testStringMap _ x = do - ThriftTestUtils.serverLog $ show x - return x - - testSet _ x = do - ThriftTestUtils.serverLog $ show x - return x - - testList _ x = do - ThriftTestUtils.serverLog $ show x - return x - - testEnum _ x = do - ThriftTestUtils.serverLog $ show x - return x - - testTypedef _ x = do - ThriftTestUtils.serverLog $ show x - return x - - testMapMap _ _ = do - return (Map.fromList [(1, Map.fromList [(2, 2)])]) - - testInsanity _ x = do - return (Map.fromList [(1, Map.fromList [(Types.Numberz_ONE, x)])]) - - testMulti _ _ _ _ _ _ _ = do - return (Types.Xtruct "" 0 0 0) - - testException _ _ = do - Control.Exception.throw (Types.Xception 1 "bya") - - testMultiException _ _ _ = do - Control.Exception.throw (Types.Xception 1 "xyz") - - testOneway _ i = do - ThriftTestUtils.serverLog $ show i - - -client :: (String, Network.PortID) -> IO () -client addr = do - to <- hOpen addr - let ps = (BinaryProtocol to, BinaryProtocol to) - - v1 <- Client.testString ps "bya" - ThriftTestUtils.clientLog $ show v1 - - v2 <- Client.testByte ps 8 - ThriftTestUtils.clientLog $ show v2 - - v3 <- Client.testByte ps (-8) - ThriftTestUtils.clientLog $ show v3 - - v4 <- Client.testI32 ps 32 - ThriftTestUtils.clientLog $ show v4 - - v5 <- Client.testI32 ps (-32) - ThriftTestUtils.clientLog $ show v5 - - v6 <- Client.testI64 ps 64 - ThriftTestUtils.clientLog $ show v6 - - v7 <- Client.testI64 ps (-64) - ThriftTestUtils.clientLog $ show v7 - - v8 <- Client.testDouble ps 3.14 - ThriftTestUtils.clientLog $ show v8 - - v9 <- Client.testDouble ps (-3.14) - ThriftTestUtils.clientLog $ show v9 - - -- TODO: Client.testBinary ... - - v10 <- Client.testMap ps (Map.fromList [(1,1),(2,2),(3,3)]) - ThriftTestUtils.clientLog $ show v10 - - v11 <- Client.testStringMap ps (Map.fromList [("a","123"),("a b","with spaces "),("same","same"),("0","numeric key")]) - ThriftTestUtils.clientLog $ show v11 - - v12 <- Client.testList ps (Vector.fromList [1,2,3,4,5]) - ThriftTestUtils.clientLog $ show v12 - - v13 <- Client.testSet ps (Set.fromList [1,2,3,4,5]) - ThriftTestUtils.clientLog $ show v13 - - v14 <- Client.testStruct ps (Types.Xtruct "hi" 4 5 0) - ThriftTestUtils.clientLog $ show v14 - - (testException ps "bad") `Control.Exception.catch` testExceptionHandler - - (testMultiException ps "ok") `Control.Exception.catch` testMultiExceptionHandler1 - (testMultiException ps "bad") `Control.Exception.catch` testMultiExceptionHandler2 `Control.Exception.catch` testMultiExceptionHandler3 - - -- ( (Client.testMultiException ps "e" "e2">> ThriftTestUtils.clientLog "bad") `Control.Exception.catch` - - tClose to - where testException ps msg = do - _ <- Client.testException ps "e" - ThriftTestUtils.clientLog msg - return () - - testExceptionHandler (e :: Types.Xception) = do - ThriftTestUtils.clientLog $ show e - - testMultiException ps msg = do - _ <- Client.testMultiException ps "e" "e2" - ThriftTestUtils.clientLog msg - return () - - testMultiExceptionHandler1 (e :: Types.Xception) = do - ThriftTestUtils.clientLog $ show e - - testMultiExceptionHandler2 (e :: Types.Xception2) = do - ThriftTestUtils.clientLog $ show e - - testMultiExceptionHandler3 (_ :: Control.Exception.SomeException) = do - ThriftTestUtils.clientLog "ok" - - -server :: Network.PortNumber -> IO () -server port = do - ThriftTestUtils.serverLog "Ready..." - (runBasicServer TestHandler ThriftTest.process port) - `Control.Exception.catch` - (\(TransportExn s _) -> error $ "FAILURE: " ++ s) - - -main :: IO () -main = ThriftTestUtils.runTest server client diff --git a/test/hs/run-test.sh b/test/hs/run-test.sh deleted file mode 100755 index ecafc18b0..000000000 --- a/test/hs/run-test.sh +++ /dev/null @@ -1,43 +0,0 @@ -#!/bin/sh - -# -# Licensed to the Apache Software Foundation (ASF) under one -# or more contributor license agreements. See the NOTICE file -# distributed with this work for additional information -# regarding copyright ownership. The ASF licenses this file -# to you under the Apache License, Version 2.0 (the -# "License"); you may not use this file except in compliance -# with the License. You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, -# software distributed under the License is distributed on an -# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -# KIND, either express or implied. See the License for the -# specific language governing permissions and limitations -# under the License. -# - -if [ "x" = "x$1" ]; then - printf "run-test.sh needs an argument, the name of the test to run. Try 'ThriftTest' or 'ProtoDebugTest'\n" - exit 2 -fi - -# Check some basics -if [ -z $BASE ]; then - BASE=../.. -fi - -# Figure out what file to run has a server -if [ -z $TEST_SOURCE_FILE ]; then - TEST_SOURCE_FILE=$BASE/test/hs/$1_Main.hs -fi - -if [ ! -e $TEST_SOURCE_FILE ]; then - printf "Missing server code file $TEST_SOURCE_FILE \n" - exit 3 -fi - -printf "Running test... \n" -runhaskell -Wall -XScopedTypeVariables -i$BASE/lib/hs/src -igen-hs $TEST_SOURCE_FILE diff --git a/tutorial/Makefile.am b/tutorial/Makefile.am index 12b3eb56d..ba445e0db 100755 --- a/tutorial/Makefile.am +++ b/tutorial/Makefile.am @@ -50,10 +50,6 @@ if WITH_RUBY SUBDIRS += rb endif -if WITH_HASKELL -SUBDIRS += hs -endif - if WITH_HAXE SUBDIRS += haxe endif @@ -107,7 +103,6 @@ EXTRA_DIST = \ d \ delphi \ erl \ - hs \ ocaml \ shared.thrift \ tutorial.thrift \ diff --git a/tutorial/hs/HaskellClient.hs b/tutorial/hs/HaskellClient.hs deleted file mode 100644 index 76a882409..000000000 --- a/tutorial/hs/HaskellClient.hs +++ /dev/null @@ -1,76 +0,0 @@ --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -import qualified Calculator -import qualified Calculator_Client as Client -import qualified SharedService_Client as SClient -import Tutorial_Types -import SharedService_Iface -import Shared_Types - -import Thrift -import Thrift.Protocol.Binary -import Thrift.Transport -import Thrift.Transport.Handle -import Thrift.Server - -import Control.Exception -import Data.Maybe -import Data.Text.Lazy -import Text.Printf -import Network - -main = do - transport <- hOpen ("localhost", PortNumber 9090) - let binProto = BinaryProtocol transport - let client = (binProto, binProto) - - Client.ping client - print "ping()" - - sum <- Client.add client 1 1 - printf "1+1=%d\n" sum - - - let work = Work { work_op = Operation_DIVIDE, - work_num1 = 1, - work_num2 = 0, - work_comment = Nothing - } - - Control.Exception.catch (printf "1/0=%d\n" =<< Client.calculate client 1 work) - (\e -> printf "InvalidOperation %s\n" (show (e :: InvalidOperation))) - - - let work = Work { work_op = Operation_SUBTRACT, - work_num1 = 15, - work_num2 = 10, - work_comment = Nothing - } - - diff <- Client.calculate client 1 work - printf "15-10=%d\n" diff - - log <- SClient.getStruct client 1 - printf "Check log: %s\n" $ unpack $ sharedStruct_value log - - -- Close! - tClose transport - - diff --git a/tutorial/hs/HaskellServer.hs b/tutorial/hs/HaskellServer.hs deleted file mode 100644 index 1594ee342..000000000 --- a/tutorial/hs/HaskellServer.hs +++ /dev/null @@ -1,103 +0,0 @@ --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -{-# LANGUAGE OverloadedStrings #-} - -import qualified Calculator -import Calculator_Iface -import Tutorial_Types -import SharedService_Iface -import Shared_Types - -import Thrift -import Thrift.Protocol.Binary -import Thrift.Transport -import Thrift.Server - -import Data.Int -import Data.String -import Data.Maybe -import Text.Printf -import Control.Exception (throw) -import Control.Concurrent.MVar -import qualified Data.Map as M -import Data.Map ((!)) -import Data.Monoid - -data CalculatorHandler = CalculatorHandler {mathLog :: MVar (M.Map Int32 SharedStruct)} - -newCalculatorHandler = do - log <- newMVar mempty - return $ CalculatorHandler log - -instance SharedService_Iface CalculatorHandler where - getStruct self k = do - myLog <- readMVar (mathLog self) - return $ (myLog ! k) - - -instance Calculator_Iface CalculatorHandler where - ping _ = - print "ping()" - - add _ n1 n2 = do - printf "add(%d,%d)\n" n1 n2 - return (n1 + n2) - - calculate self mlogid mwork = do - printf "calculate(%d, %s)\n" logid (show work) - - let val = case op work of - Operation_ADD -> - num1 work + num2 work - Operation_SUBTRACT -> - num1 work - num2 work - Operation_MULTIPLY -> - num1 work * num2 work - Operation_DIVIDE -> - if num2 work == 0 then - throw $ - InvalidOperation { - invalidOperation_whatOp = fromIntegral $ fromEnum $ op work, - invalidOperation_why = "Cannot divide by 0" - } - else - num1 work `div` num2 work - - let logEntry = SharedStruct logid (fromString $ show $ val) - modifyMVar_ (mathLog self) $ return .(M.insert logid logEntry) - - return $! val - - where - -- stupid dynamic languages f'ing it up - num1 = work_num1 - num2 = work_num2 - op = work_op - logid = mlogid - work = mwork - - zip _ = - print "zip()" - -main = do - handler <- newCalculatorHandler - print "Starting the server..." - runBasicServer handler Calculator.process 9090 - print "done." diff --git a/tutorial/hs/LICENSE b/tutorial/hs/LICENSE deleted file mode 100644 index 3b6d7d74c..000000000 --- a/tutorial/hs/LICENSE +++ /dev/null @@ -1,239 +0,0 @@ - - Apache License - Version 2.0, January 2004 - http://www.apache.org/licenses/ - - TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION - - 1. Definitions. - - "License" shall mean the terms and conditions for use, reproduction, - and distribution as defined by Sections 1 through 9 of this document. - - "Licensor" shall mean the copyright owner or entity authorized by - the copyright owner that is granting the License. - - "Legal Entity" shall mean the union of the acting entity and all - other entities that control, are controlled by, or are under common - control with that entity. For the purposes of this definition, - "control" means (i) the power, direct or indirect, to cause the - direction or management of such entity, whether by contract or - otherwise, or (ii) ownership of fifty percent (50%) or more of the - outstanding shares, or (iii) beneficial ownership of such entity. - - "You" (or "Your") shall mean an individual or Legal Entity - exercising permissions granted by this License. - - "Source" form shall mean the preferred form for making modifications, - including but not limited to software source code, documentation - source, and configuration files. - - "Object" form shall mean any form resulting from mechanical - transformation or translation of a Source form, including but - not limited to compiled object code, generated documentation, - and conversions to other media types. - - "Work" shall mean the work of authorship, whether in Source or - Object form, made available under the License, as indicated by a - copyright notice that is included in or attached to the work - (an example is provided in the Appendix below). - - "Derivative Works" shall mean any work, whether in Source or Object - form, that is based on (or derived from) the Work and for which the - editorial revisions, annotations, elaborations, or other modifications - represent, as a whole, an original work of authorship. For the purposes - of this License, Derivative Works shall not include works that remain - separable from, or merely link (or bind by name) to the interfaces of, - the Work and Derivative Works thereof. - - "Contribution" shall mean any work of authorship, including - the original version of the Work and any modifications or additions - to that Work or Derivative Works thereof, that is intentionally - submitted to Licensor for inclusion in the Work by the copyright owner - or by an individual or Legal Entity authorized to submit on behalf of - the copyright owner. For the purposes of this definition, "submitted" - means any form of electronic, verbal, or written communication sent - to the Licensor or its representatives, including but not limited to - communication on electronic mailing lists, source code control systems, - and issue tracking systems that are managed by, or on behalf of, the - Licensor for the purpose of discussing and improving the Work, but - excluding communication that is conspicuously marked or otherwise - designated in writing by the copyright owner as "Not a Contribution." - - "Contributor" shall mean Licensor and any individual or Legal Entity - on behalf of whom a Contribution has been received by Licensor and - subsequently incorporated within the Work. - - 2. Grant of Copyright License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - copyright license to reproduce, prepare Derivative Works of, - publicly display, publicly perform, sublicense, and distribute the - Work and such Derivative Works in Source or Object form. - - 3. Grant of Patent License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - (except as stated in this section) patent license to make, have made, - use, offer to sell, sell, import, and otherwise transfer the Work, - where such license applies only to those patent claims licensable - by such Contributor that are necessarily infringed by their - Contribution(s) alone or by combination of their Contribution(s) - with the Work to which such Contribution(s) was submitted. If You - institute patent litigation against any entity (including a - cross-claim or counterclaim in a lawsuit) alleging that the Work - or a Contribution incorporated within the Work constitutes direct - or contributory patent infringement, then any patent licenses - granted to You under this License for that Work shall terminate - as of the date such litigation is filed. - - 4. Redistribution. You may reproduce and distribute copies of the - Work or Derivative Works thereof in any medium, with or without - modifications, and in Source or Object form, provided that You - meet the following conditions: - - (a) You must give any other recipients of the Work or - Derivative Works a copy of this License; and - - (b) You must cause any modified files to carry prominent notices - stating that You changed the files; and - - (c) You must retain, in the Source form of any Derivative Works - that You distribute, all copyright, patent, trademark, and - attribution notices from the Source form of the Work, - excluding those notices that do not pertain to any part of - the Derivative Works; and - - (d) If the Work includes a "NOTICE" text file as part of its - distribution, then any Derivative Works that You distribute must - include a readable copy of the attribution notices contained - within such NOTICE file, excluding those notices that do not - pertain to any part of the Derivative Works, in at least one - of the following places: within a NOTICE text file distributed - as part of the Derivative Works; within the Source form or - documentation, if provided along with the Derivative Works; or, - within a display generated by the Derivative Works, if and - wherever such third-party notices normally appear. The contents - of the NOTICE file are for informational purposes only and - do not modify the License. You may add Your own attribution - notices within Derivative Works that You distribute, alongside - or as an addendum to the NOTICE text from the Work, provided - that such additional attribution notices cannot be construed - as modifying the License. - - You may add Your own copyright statement to Your modifications and - may provide additional or different license terms and conditions - for use, reproduction, or distribution of Your modifications, or - for any such Derivative Works as a whole, provided Your use, - reproduction, and distribution of the Work otherwise complies with - the conditions stated in this License. - - 5. Submission of Contributions. Unless You explicitly state otherwise, - any Contribution intentionally submitted for inclusion in the Work - by You to the Licensor shall be under the terms and conditions of - this License, without any additional terms or conditions. - Notwithstanding the above, nothing herein shall supersede or modify - the terms of any separate license agreement you may have executed - with Licensor regarding such Contributions. - - 6. Trademarks. This License does not grant permission to use the trade - names, trademarks, service marks, or product names of the Licensor, - except as required for reasonable and customary use in describing the - origin of the Work and reproducing the content of the NOTICE file. - - 7. Disclaimer of Warranty. Unless required by applicable law or - agreed to in writing, Licensor provides the Work (and each - Contributor provides its Contributions) on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or - implied, including, without limitation, any warranties or conditions - of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A - PARTICULAR PURPOSE. You are solely responsible for determining the - appropriateness of using or redistributing the Work and assume any - risks associated with Your exercise of permissions under this License. - - 8. Limitation of Liability. In no event and under no legal theory, - whether in tort (including negligence), contract, or otherwise, - unless required by applicable law (such as deliberate and grossly - negligent acts) or agreed to in writing, shall any Contributor be - liable to You for damages, including any direct, indirect, special, - incidental, or consequential damages of any character arising as a - result of this License or out of the use or inability to use the - Work (including but not limited to damages for loss of goodwill, - work stoppage, computer failure or malfunction, or any and all - other commercial damages or losses), even if such Contributor - has been advised of the possibility of such damages. - - 9. Accepting Warranty or Additional Liability. While redistributing - the Work or Derivative Works thereof, You may choose to offer, - and charge a fee for, acceptance of support, warranty, indemnity, - or other liability obligations and/or rights consistent with this - License. However, in accepting such obligations, You may act only - on Your own behalf and on Your sole responsibility, not on behalf - of any other Contributor, and only if You agree to indemnify, - defend, and hold each Contributor harmless for any liability - incurred by, or claims asserted against, such Contributor by reason - of your accepting any such warranty or additional liability. - - END OF TERMS AND CONDITIONS - - APPENDIX: How to apply the Apache License to your work. - - To apply the Apache License to your work, attach the following - boilerplate notice, with the fields enclosed by brackets "[]" - replaced with your own identifying information. (Don't include - the brackets!) The text should be enclosed in the appropriate - comment syntax for the file format. We also recommend that a - file or class name and description of purpose be included on the - same "printed page" as the copyright notice for easier - identification within third-party archives. - - Copyright [yyyy] [name of copyright owner] - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. - --------------------------------------------------- -SOFTWARE DISTRIBUTED WITH THRIFT: - -The Apache Thrift software includes a number of subcomponents with -separate copyright notices and license terms. Your use of the source -code for the these subcomponents is subject to the terms and -conditions of the following licenses. - --------------------------------------------------- -Portions of the following files are licensed under the MIT License: - - lib/erl/src/Makefile.am - -Please see doc/otp-base-license.txt for the full terms of this license. - --------------------------------------------------- -For the aclocal/ax_boost_base.m4 and contrib/fb303/aclocal/ax_boost_base.m4 components: - -# Copyright (c) 2007 Thomas Porschberg <thomas@randspringer.de> -# -# Copying and distribution of this file, with or without -# modification, are permitted in any medium without royalty provided -# the copyright notice and this notice are preserved. - --------------------------------------------------- -For the lib/nodejs/lib/thrift/json_parse.js: - -/* - json_parse.js - 2015-05-02 - Public Domain. - NO WARRANTY EXPRESSED OR IMPLIED. USE AT YOUR OWN RISK. - -*/ -(By Douglas Crockford <douglas@crockford.com>) --------------------------------------------------- diff --git a/tutorial/hs/Makefile.am b/tutorial/hs/Makefile.am deleted file mode 100755 index 9c6fd8308..000000000 --- a/tutorial/hs/Makefile.am +++ /dev/null @@ -1,47 +0,0 @@ -# -# Licensed to the Apache Software Foundation (ASF) under one -# or more contributor license agreements. See the NOTICE file -# distributed with this work for additional information -# regarding copyright ownership. The ASF licenses this file -# to you under the Apache License, Version 2.0 (the -# "License"); you may not use this file except in compliance -# with the License. You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, -# software distributed under the License is distributed on an -# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -# KIND, either express or implied. See the License for the -# specific language governing permissions and limitations -# under the License. -# - -all-local: - $(top_builddir)/compiler/cpp/thrift --gen hs -r $(top_srcdir)/tutorial/tutorial.thrift - $(CABAL) install - -install-exec-hook: - $(CABAL) install - -# Make sure this doesn't fail if Haskell is not configured. -clean-local: - $(CABAL) clean - $(RM) -r dist/ - $(RM) -r gen-*/ - -dist-hook: - $(RM) -r $(distdir)/dist/ - $(RM) -r $(distdir)/gen-*/ - -check-local: - $(CABAL) check - -tutorialserver: all - dist/build/HaskellServer/HaskellServer - -tutorialclient: all - dist/build/HaskellClient/HaskellClient - -EXTRA_DIST = \ - LICENSE diff --git a/tutorial/hs/Setup.lhs b/tutorial/hs/Setup.lhs deleted file mode 100644 index c7df182d3..000000000 --- a/tutorial/hs/Setup.lhs +++ /dev/null @@ -1,21 +0,0 @@ -#!/usr/bin/env runhaskell - -> -- Licensed to the Apache Software Foundation (ASF) under one -> -- or more contributor license agreements. See the NOTICE file -> -- distributed with this work for additional information -> -- regarding copyright ownership. The ASF licenses this file -> -- to you under the Apache License, Version 2.0 (the -> -- "License"); you may not use this file except in compliance -> -- with the License. You may obtain a copy of the License at -> -- -> -- http://www.apache.org/licenses/LICENSE-2.0 -> -- -> -- Unless required by applicable law or agreed to in writing, -> -- software distributed under the License is distributed on an -> -- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -> -- KIND, either express or implied. See the License for the -> -- specific language governing permissions and limitations -> -- under the License. - -> import Distribution.Simple -> main = defaultMain diff --git a/tutorial/hs/ThriftTutorial.cabal b/tutorial/hs/ThriftTutorial.cabal deleted file mode 100755 index fc778d979..000000000 --- a/tutorial/hs/ThriftTutorial.cabal +++ /dev/null @@ -1,73 +0,0 @@ --- --- Licensed to the Apache Software Foundation (ASF) under one --- or more contributor license agreements. See the NOTICE file --- distributed with this work for additional information --- regarding copyright ownership. The ASF licenses this file --- to you under the Apache License, Version 2.0 (the --- "License"); you may not use this file except in compliance --- with the License. You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, --- software distributed under the License is distributed on an --- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY --- KIND, either express or implied. See the License for the --- specific language governing permissions and limitations --- under the License. --- - -Name: ThriftTutorial -Version: 0.15.0 -Cabal-Version: >= 1.4 -License: OtherLicense -Category: Foreign -Build-Type: Simple -Synopsis: Thrift Tutorial library package -Homepage: http://thrift.apache.org -Bug-Reports: https://issues.apache.org/jira/browse/THRIFT -Maintainer: dev@thrift.apache.org -License-File: LICENSE - -Description: - Haskell tutorial for the Apache Thrift RPC system. Requires the use of the thrift code generator. - -flag network-uri - description: Get Network.URI from the network-uri package - default: True - -Executable HaskellServer - Main-is: HaskellServer.hs - Hs-Source-Dirs: - ., gen-hs/ - Build-Depends: - base >= 4, base < 5, ghc-prim, containers, thrift, vector, unordered-containers, text, hashable, bytestring, QuickCheck - Extensions: - DeriveDataTypeable, - ExistentialQuantification, - FlexibleInstances, - KindSignatures, - MagicHash, - RankNTypes, - ScopedTypeVariables, - TypeSynonymInstances - -Executable HaskellClient - Main-is: HaskellClient.hs - Hs-Source-Dirs: - ., gen-hs/ - Build-Depends: - base >= 4, base < 5, ghc-prim, containers, thrift, vector, QuickCheck - if flag(network-uri) - build-depends: network-uri >= 2.6, network >= 2.6 - else - build-depends: network < 2.6 - Extensions: - DeriveDataTypeable, - ExistentialQuantification, - FlexibleInstances, - KindSignatures, - MagicHash, - RankNTypes, - ScopedTypeVariables, - TypeSynonymInstances |