summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJens Geyer <jensg@apache.org>2021-03-20 18:07:17 +0100
committerJens Geyer <jensg@apache.org>2021-03-22 09:42:38 +0100
commit66d897667c451ef6560d89b979b7001c57a3eda6 (patch)
tree4420429109c582375fc68aa125a2b6f6b8019dd3
parentcd2fae091b9bafd0977ef290f722532c36a64d2e (diff)
downloadthrift-66d897667c451ef6560d89b979b7001c57a3eda6.tar.gz
THRIFT-5347 Remove deprecated Haskell bindings
Client: hs Patch: Jens Geyer This closes #2352
-rw-r--r--.travis.yml2
-rw-r--r--CMakeLists.txt7
-rw-r--r--LANGUAGES.md11
-rwxr-xr-xMakefile.am2
-rw-r--r--build/appveyor/MSVC-appveyor-install.bat3
-rw-r--r--build/cmake/DefineOptions.cmake11
-rw-r--r--build/cmake/FindCabal.cmake30
-rw-r--r--build/cmake/FindGHC.cmake36
-rw-r--r--build/docker/README.md1
-rw-r--r--build/docker/msvc2017/Dockerfile3
-rw-r--r--build/docker/old/centos-7.3/Dockerfile3
-rw-r--r--build/docker/old/debian-jessie/Dockerfile3
-rw-r--r--build/docker/old/debian-stretch/Dockerfile5
-rw-r--r--build/docker/old/ubuntu-artful/Dockerfile5
-rw-r--r--build/docker/old/ubuntu-trusty/Dockerfile5
-rw-r--r--build/docker/ubuntu-bionic/Dockerfile5
-rw-r--r--build/docker/ubuntu-disco/Dockerfile5
-rw-r--r--build/docker/ubuntu-xenial/Dockerfile12
-rwxr-xr-xbuild/veralign.sh2
-rw-r--r--compiler/cpp/CMakeLists.txt1
-rw-r--r--compiler/cpp/Makefile.am1
-rw-r--r--compiler/cpp/compiler.vcxproj1
-rw-r--r--compiler/cpp/compiler.vcxproj.filters3
-rw-r--r--compiler/cpp/src/thrift/generate/t_generator.cc3
-rw-r--r--compiler/cpp/src/thrift/generate/t_hs_generator.cc1717
-rw-r--r--compiler/cpp/tests/CMakeLists.txt1
-rwxr-xr-xconfigure.ac38
-rw-r--r--contrib/Vagrantfile4
-rw-r--r--contrib/vagrant/centos-6.5/Vagrantfile8
-rwxr-xr-xdoap.rdf1
-rw-r--r--doc/ReleaseManagement.md2
-rw-r--r--doc/install/debian.md2
-rw-r--r--lib/Makefile.am4
-rw-r--r--lib/hs/CMakeLists.txt93
-rw-r--r--lib/hs/LICENSE202
-rw-r--r--lib/hs/Makefile.am53
-rw-r--r--lib/hs/README.md113
-rwxr-xr-xlib/hs/Setup.lhs21
-rw-r--r--lib/hs/TODO2
-rw-r--r--lib/hs/coding_standards.md1
-rw-r--r--lib/hs/src/Thrift.hs114
-rw-r--r--lib/hs/src/Thrift/Arbitraries.hs55
-rw-r--r--lib/hs/src/Thrift/Protocol.hs136
-rw-r--r--lib/hs/src/Thrift/Protocol/Binary.hs212
-rw-r--r--lib/hs/src/Thrift/Protocol/Compact.hs311
-rw-r--r--lib/hs/src/Thrift/Protocol/Header.hs141
-rw-r--r--lib/hs/src/Thrift/Protocol/JSON.hs362
-rw-r--r--lib/hs/src/Thrift/Server.hs66
-rw-r--r--lib/hs/src/Thrift/Transport.hs65
-rw-r--r--lib/hs/src/Thrift/Transport/Empty.hs36
-rw-r--r--lib/hs/src/Thrift/Transport/Framed.hs99
-rw-r--r--lib/hs/src/Thrift/Transport/Handle.hs85
-rw-r--r--lib/hs/src/Thrift/Transport/Header.hs354
-rw-r--r--lib/hs/src/Thrift/Transport/HttpClient.hs101
-rw-r--r--lib/hs/src/Thrift/Transport/IOBuffer.hs69
-rw-r--r--lib/hs/src/Thrift/Transport/Memory.hs77
-rw-r--r--lib/hs/src/Thrift/Types.hs130
-rw-r--r--lib/hs/test/BinarySpec.hs91
-rw-r--r--lib/hs/test/CompactSpec.hs81
-rw-r--r--lib/hs/test/JSONSpec.hs225
-rw-r--r--lib/hs/test/Spec.hs38
-rw-r--r--lib/hs/thrift.cabal84
-rwxr-xr-xtest/Makefile.am5
-rw-r--r--test/hs/CMakeLists.txt114
-rw-r--r--test/hs/ConstantsDemo_Main.hs68
-rw-r--r--test/hs/DebugProtoTest_Main.hs172
-rw-r--r--test/hs/Include_Main.hs7
-rw-r--r--test/hs/Makefile.am50
-rw-r--r--test/hs/TestClient.hs306
-rw-r--r--test/hs/TestServer.hs312
-rw-r--r--test/hs/ThriftTestUtils.hs65
-rw-r--r--test/hs/ThriftTest_Main.hs214
-rwxr-xr-xtest/hs/run-test.sh43
-rwxr-xr-xtutorial/Makefile.am5
-rw-r--r--tutorial/hs/HaskellClient.hs76
-rw-r--r--tutorial/hs/HaskellServer.hs103
-rw-r--r--tutorial/hs/LICENSE239
-rwxr-xr-xtutorial/hs/Makefile.am47
-rw-r--r--tutorial/hs/Setup.lhs21
-rwxr-xr-xtutorial/hs/ThriftTutorial.cabal73
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
diff --git a/doap.rdf b/doap.rdf
index 6094de728..ad324a8ee 100755
--- a/doap.rdf
+++ b/doap.rdf
@@ -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