Moving from govendor to dep, updated dependencies (#48)

* Moving from govendor to dep.

* Making the pull request template more friendly.

* Fixing akward space in PR template.

* goimports run on whole project using ` goimports -w $(find . -type f -name '*.go' -not -path "./vendor/*" -not -path "./gen-go/*")`

source of command: https://gist.github.com/bgentry/fd1ffef7dbde01857f66
This commit is contained in:
Renan DelValle 2018-01-07 13:13:47 -08:00 committed by GitHub
parent 9631aa3aab
commit 8d445c1c77
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
2186 changed files with 400410 additions and 352 deletions

93
vendor/git.apache.org/thrift.git/lib/hs/CMakeLists.txt generated vendored Normal file
View file

@ -0,0 +1,93 @@
#
# 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_soruces
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)
elseif(CMAKE_BUILD_TYPE STREQUAL "Release")
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()

202
vendor/git.apache.org/thrift.git/lib/hs/LICENSE generated vendored Normal file
View file

@ -0,0 +1,202 @@
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.

50
vendor/git.apache.org/thrift.git/lib/hs/Makefile.am generated vendored Normal file
View file

@ -0,0 +1,50 @@
#
# 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
maintainer-clean-local:
$(CABAL) clean
check-local:
$(CABAL) check
$(CABAL) install --only-dependencies --enable-tests
$(CABAL) configure --enable-tests
$(CABAL) build
$(CABAL) test

99
vendor/git.apache.org/thrift.git/lib/hs/README.md generated vendored Normal file
View file

@ -0,0 +1,99 @@
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.

21
vendor/git.apache.org/thrift.git/lib/hs/Setup.lhs generated vendored Executable file
View file

@ -0,0 +1,21 @@
#!/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

2
vendor/git.apache.org/thrift.git/lib/hs/TODO generated vendored Normal file
View file

@ -0,0 +1,2 @@
The library could stand to be built up more.
Many modules need export lists.

80
vendor/git.apache.org/thrift.git/lib/hs/Thrift.cabal generated vendored Normal file
View file

@ -0,0 +1,80 @@
--
-- 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.10.0
Cabal-Version: >= 1.8
License: OtherLicense
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, 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
else
build-depends: network < 2.6
Exposed-Modules:
Thrift,
Thrift.Arbitraries
Thrift.Protocol,
Thrift.Protocol.Binary,
Thrift.Protocol.Compact,
Thrift.Protocol.JSON,
Thrift.Server,
Thrift.Transport,
Thrift.Transport.Empty,
Thrift.Transport.Framed,
Thrift.Transport.Handle,
Thrift.Transport.HttpClient,
Thrift.Transport.IOBuffer,
Thrift.Transport.Memory,
Thrift.Types
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

View file

@ -0,0 +1 @@
Please follow [General Coding Standards](/doc/coding_standards.md)

114
vendor/git.apache.org/thrift.git/lib/hs/src/Thrift.hs generated vendored Normal file
View file

@ -0,0 +1,114 @@
{-# 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, Transport t) => p t -> 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, Transport t) => p t -> 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

View file

@ -0,0 +1,55 @@
{-# 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.
-}

View file

@ -0,0 +1,149 @@
{-# 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(..)
, ProtocolExn(..)
, ProtocolExnType(..)
, getTypeOf
, runParser
, versionMask
, version1
, bsToDouble
, bsToDoubleLE
) where
import Control.Exception
import Data.Attoparsec.ByteString
import Data.Bits
import Data.ByteString.Lazy (ByteString, toStrict)
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 (Storable, peek, poke)
import System.IO.Unsafe
import qualified Data.ByteString as BS
import qualified Data.HashMap.Strict as Map
import Thrift.Types
import Thrift.Transport
versionMask :: Int32
versionMask = fromIntegral (0xffff0000 :: Word32)
version1 :: Int32
version1 = fromIntegral (0x80010000 :: Word32)
class Protocol a where
getTransport :: Transport t => a t -> t
writeMessageBegin :: Transport t => a t -> (Text, MessageType, Int32) -> IO ()
writeMessageEnd :: Transport t => a t -> IO ()
writeMessageEnd _ = return ()
readMessageBegin :: Transport t => a t -> IO (Text, MessageType, Int32)
readMessageEnd :: Transport t => a t -> IO ()
readMessageEnd _ = return ()
serializeVal :: Transport t => a t -> ThriftVal -> ByteString
deserializeVal :: Transport t => a t -> ThriftType -> ByteString -> ThriftVal
writeVal :: Transport t => a t -> ThriftVal -> IO ()
writeVal p = tWrite (getTransport p) . serializeVal p
readVal :: Transport t => a t -> ThriftType -> IO 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, Transport t, Show a) => p t -> Parser a -> IO a
runParser prot p = refill >>= getResult . parse p
where
refill = handle handleEOF $ toStrict <$> tReadAll (getTransport prot) 1
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)

View file

@ -0,0 +1,191 @@
--
-- 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(..)
) 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 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
data BinaryProtocol a = BinaryProtocol a
-- 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 Protocol BinaryProtocol where
getTransport (BinaryProtocol t) = t
writeMessageBegin p (n, t, s) = tWrite (getTransport p) $ toLazyByteString $
buildBinaryValue (TI32 (version1 .|. fromIntegral (fromEnum t))) <>
buildBinaryValue (TString $ encodeUtf8 n) <>
buildBinaryValue (TI32 s)
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)
serializeVal _ = toLazyByteString . buildBinaryValue
deserializeVal _ ty bs =
case LP.eitherResult $ LP.parse (parseBinaryValue ty) bs of
Left s -> error s
Right val -> val
readVal p = runParser p . parseBinaryValue
-- | 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)

View file

@ -0,0 +1,301 @@
--
-- 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(..)
) where
import Control.Applicative
import Control.Exception ( throw )
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 hiding (versionMask)
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
instance Protocol CompactProtocol where
getTransport (CompactProtocol t) = t
writeMessageBegin p (n, t, s) = tWrite (getTransport p) $ toLazyByteString $
B.word8 protocolID <>
B.word8 ((version .&. versionMask) .|.
(((fromIntegral $ fromEnum t) `shiftL`
typeShiftAmount) .&. typeMask)) <>
buildVarint (i32ToZigZag s) <>
buildCompactValue (TString $ encodeUtf8 n)
readMessageBegin p = 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)
serializeVal _ = toLazyByteString . buildCompactValue
deserializeVal _ ty bs =
case LP.eitherResult $ LP.parse (parseCompactValue ty) bs of
Left s -> error s
Right val -> val
readVal p ty = runParser p $ parseCompactValue ty
-- | 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"

View file

@ -0,0 +1,352 @@
--
-- 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.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.Base64 as B64
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'
instance Protocol JSONProtocol where
getTransport (JSONProtocol t) = t
writeMessageBegin (JSONProtocol t) (s, ty, sq) = 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 ','
writeMessageEnd (JSONProtocol t) = tWrite t "]"
readMessageBegin p = 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 p = void $ runParser p (PC.char8 ']')
serializeVal _ = toLazyByteString . buildJSONValue
deserializeVal _ ty bs =
case LP.eitherResult $ LP.parse (parseJSONValue ty) bs of
Left s -> error s
Right val -> val
readVal p ty = runParser p $ skipSpace *> parseJSONValue ty
-- 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"

View file

@ -0,0 +1,66 @@
{-# 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 :: (Transport t, Protocol i, Protocol o)
=> (Socket -> IO (i t, o t))
-> h
-> (h -> (i t, o t) -> 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) }

View file

@ -0,0 +1,65 @@
{-# 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 )

View file

@ -0,0 +1,36 @@
{-# 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 ()

View file

@ -0,0 +1,99 @@
{-# 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 <- tRead (wrappedTrans trans) 4
let sz = fromIntegral (B.decode szBs :: Int32)
-- Read the frame and stuff it into the read buffer.
bs <- tRead (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

View file

@ -0,0 +1,68 @@
{-# 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 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 = LBS.hGet h n `Control.Exception.catch` handleEOF mempty
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
handleEOF :: a -> IOError -> IO a
handleEOF a e = if isEOFError e
then return a
else throw $ TransportExn "TChannelTransport: Could not read" TE_UNKNOWN

View file

@ -0,0 +1,101 @@
{-# 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

View file

@ -0,0 +1,69 @@
--
-- 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

View file

@ -0,0 +1,77 @@
--
-- 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)

View file

@ -0,0 +1,130 @@
-- 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]

View file

@ -0,0 +1,91 @@
--
-- 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)

View file

@ -0,0 +1,81 @@
--
-- 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)

View file

@ -0,0 +1,225 @@
--
-- 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)

38
vendor/git.apache.org/thrift.git/lib/hs/test/Spec.hs generated vendored Normal file
View file

@ -0,0 +1,38 @@
--
-- 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