greskell-websocket 0.1.2.6 → 1.0.0.6
raw patch · 27 files changed
Files
- ChangeLog.md +37/−0
- greskell-websocket.cabal +42/−24
- src/Network/Greskell/WebSocket.hs +5/−5
- src/Network/Greskell/WebSocket/Client.hs +25/−25
- src/Network/Greskell/WebSocket/Client/Impl.hs +61/−64
- src/Network/Greskell/WebSocket/Client/Options.hs +35/−35
- src/Network/Greskell/WebSocket/Codec.hs +26/−23
- src/Network/Greskell/WebSocket/Codec/JSON.hs +8/−8
- src/Network/Greskell/WebSocket/Connection.hs +24/−24
- src/Network/Greskell/WebSocket/Connection/Impl.hs +93/−85
- src/Network/Greskell/WebSocket/Connection/Settings.hs +45/−41
- src/Network/Greskell/WebSocket/Connection/Type.hs +53/−53
- src/Network/Greskell/WebSocket/Request.hs +25/−24
- src/Network/Greskell/WebSocket/Request/Aeson.hs +10/−12
- src/Network/Greskell/WebSocket/Request/Common.hs +21/−19
- src/Network/Greskell/WebSocket/Request/Session.hs +45/−44
- src/Network/Greskell/WebSocket/Request/Standard.hs +32/−31
- src/Network/Greskell/WebSocket/Response.hs +71/−100
- src/Network/Greskell/WebSocket/Util.hs +6/−6
- test/Network/Greskell/WebSocket/Codec/JSONSpec.hs +43/−40
- test/Network/Greskell/WebSocket/ResponseSpec.hs +25/−0
- test/ServerTest.hs +8/−4
- test/ServerTest/Client.hs +38/−39
- test/ServerTest/Connection.hs +76/−68
- test/TestUtil/Env.hs +7/−7
- test/TestUtil/MockServer.hs +18/−18
- test/TestUtil/TCounter.hs +19/−19
ChangeLog.md view
@@ -1,5 +1,42 @@ # Revision history for greskell-websocket +## 1.0.0.6 -- 2026-05-25++- Support aeson-2.3.++## 1.0.0.5 -- 2026-04-21++- Bump dependency version bounds.++## 1.0.0.4 -- 2025-01-30++* Fix the bug where greskell-websocket didn't work at all with `async-2.2.5`. (see https://github.com/debug-ito/greskell/pull/17 )+* Support ghc-9.12 (base-4.21).++## 1.0.0.3 -- 2024-11-21++* Confirm test with `hashtable-1.4`.++## 1.0.0.2 -- 2024-09-12++* Update dependency version bounds with cabal-plan-bounds.+ This adds support for new packages, while drops support for old ones.++## 1.0.0.1 -- 2022-11-24++* Confirm test with ghc-9.2.5, vector-0.13.0.0 and aeson-2.1.0.0.+* Remove doctests. This is because it's so difficult to maintain doctests with recent GHCs and cabals.+ * doctests have been moved to `examples` function defined in some modules.+* Use stylish-haskell to format codes.++## 1.0.0.0 -- 2021-12-28++* **BREAKING CHANGE**: Now greskell-websocket uses `aeson-2`.+ As a result, now implementation of `Data.Aeson.Object` has been changed from `HashMap` to `KeyMap`.+ Some types in greskell-websocket (e.g. `ResponseResult`) directly uses the `Object` type.++* Confirm test with `aeson-2.0.2.0`, `hashtables-1.3`, `greskell-core-1.0`.+ ## 0.1.2.6 -- 2021-11-08 * Confirm test with `base-4.15.0.0`
greskell-websocket.cabal view
@@ -1,5 +1,5 @@ name: greskell-websocket-version: 0.1.2.6+version: 1.0.0.6 author: Toshio Ito <debug.ito@gmail.com> maintainer: Toshio Ito <debug.ito@gmail.com> license: BSD3@@ -11,7 +11,7 @@ This package is based on [greskell-core](http://hackage.haskell.org/package/greskell-core), and best used with [greskell](http://hackage.haskell.org/package/greskell) package. category: Network-cabal-version: >= 1.10+cabal-version: 2.0 build-type: Simple extra-source-files: README.md, ChangeLog.md, test/samples/*.json@@ -23,7 +23,7 @@ hs-source-dirs: src ghc-options: -Wall -fno-warn-unused-imports -- default-extensions: - other-extensions: OverloadedStrings, DuplicateRecordFields,+ other-extensions: OverloadedStrings, DuplicateRecordFields, DataKinds, TypeApplications, DeriveGeneric, PartialTypeSignatures, FlexibleContexts, CPP exposed-modules: Network.Greskell.WebSocket,@@ -43,20 +43,20 @@ Network.Greskell.WebSocket.Connection.Type, Network.Greskell.WebSocket.Client.Impl, Network.Greskell.WebSocket.Util- build-depends: base >=4.9.1.0 && <4.16,- greskell-core >=0.1.2.0 && <0.2,- bytestring >=0.10.8.1 && <0.11,- base64-bytestring >=1.0.0.1 && <1.3,- text >=1.2.2.2 && <1.3,- aeson >=1.1.2.0 && <1.6,- unordered-containers >=0.2.8 && <0.3,- uuid >=1.3.13 && <1.4,- async >=2.1.1.1 && <2.3,- stm >=2.4.4.1 && <2.6,- websockets >=0.10 && <0.13,- hashtables >=1.2.2.1 && <1.3,- safe-exceptions >=0.1.6 && <0.2,- vector >=0.12.0.1 && <0.13+ build-depends: base ^>=4.13.0 || ^>=4.14.0 || ^>=4.15.0 || ^>=4.16.0 || ^>=4.17.0 || ^>=4.18.0 || ^>=4.19.0 || ^>=4.20.0 || ^>=4.21.0 || ^>=4.22.0,+ greskell-core ^>=1.0.0,+ bytestring ^>=0.10.9 || ^>=0.11.3 || ^>=0.12.0,+ base64-bytestring ^>=1.2.1,+ text ^>=1.2.3 || ^>=2.0.2 || ^>=2.1,+ aeson ^>=2.0.2 || ^>=2.1.0 || ^>=2.2.3 || ^>=2.3.0,+ unordered-containers ^>=0.2.15,+ uuid ^>=1.3.15,+ async ^>=2.2.4,+ stm ^>=2.5.0,+ websockets ^>=0.12.7 || ^>=0.13.0,+ hashtables ^>=1.3 || ^>=1.4.0,+ safe-exceptions ^>=0.1.7,+ vector ^>=0.12.3 || ^>=0.13.0 -- executable greskell-websocket -- default-language: Haskell2010@@ -77,10 +77,18 @@ -- default-extensions: other-extensions: OverloadedStrings, DuplicateRecordFields, NoMonomorphismRestriction- other-modules: Network.Greskell.WebSocket.Codec.JSONSpec+ other-modules: Network.Greskell.WebSocket.Codec.JSONSpec,+ Network.Greskell.WebSocket.ResponseSpec build-tool-depends: hspec-discover:hspec-discover- build-depends: base, greskell-websocket, aeson, uuid, bytestring, unordered-containers, vector, greskell-core,- hspec >=2.4.4+ build-depends: base ^>=4.13.0 || ^>=4.14.0 || ^>=4.15.0 || ^>=4.16.0 || ^>=4.17.0 || ^>=4.18.0 || ^>=4.19.0 || ^>=4.20.0 || ^>=4.21.0 || ^>=4.22.0,+ greskell-websocket,+ aeson ^>=2.0.2 || ^>=2.1.0 || ^>=2.2.3 || ^>=2.3.0,+ uuid ^>=1.3.15,+ bytestring ^>=0.10.9 || ^>=0.11.3 || ^>=0.12.0,+ unordered-containers ^>=0.2.15,+ vector ^>=0.12.3 || ^>=0.13.0,+ greskell-core ^>=1.0.0,+ hspec ^>=2.9.1 || ^>=2.10.6 || ^>=2.11.9 flag server-test@@ -102,10 +110,20 @@ ServerTest.Connection, ServerTest.Client if flag(server-test)- build-depends: base, greskell-websocket, greskell-core,- aeson, uuid, unordered-containers, text, async, safe-exceptions,- websockets, bytestring, stm, vector,- hspec+ build-depends: base ^>=4.13.0 || ^>=4.14.0 || ^>=4.15.0 || ^>=4.16.0 || ^>=4.17.0 || ^>=4.18.0 || ^>=4.19.0 || ^>=4.20.0 || ^>=4.21.0 || ^>=4.22.0,+ greskell-websocket,+ greskell-core ^>=1.0.0,+ aeson ^>=2.0.2 || ^>=2.1.0 || ^>=2.2.3 || ^>=2.3.0,+ uuid ^>=1.3.15,+ unordered-containers ^>=0.2.15,+ text ^>=1.2.3 || ^>=2.0.2 || ^>=2.1,+ async ^>=2.2.4,+ safe-exceptions ^>=0.1.7,+ websockets ^>=0.12.7 || ^>=0.13.0,+ bytestring ^>=0.10.9 || ^>=0.11.3 || ^>=0.12.0,+ stm ^>=2.5.0,+ vector ^>=0.12.3 || ^>=0.13.0,+ hspec ^>=2.9.1 || ^>=2.10.6 || ^>=2.11.9 else buildable: False
src/Network/Greskell/WebSocket.hs view
@@ -2,13 +2,13 @@ -- Module: Network.Greskell.WebSocket -- Description: Client of Gremlin Server using WebSocket -- Maintainer: Toshio Ito <debug.ito@gmail.com>--- +-- module Network.Greskell.WebSocket- ( module Network.Greskell.WebSocket.Client- -- $doc- ) where+ ( -- $doc+ module Network.Greskell.WebSocket.Client+ ) where -import Network.Greskell.WebSocket.Client+import Network.Greskell.WebSocket.Client -- $doc --
src/Network/Greskell/WebSocket/Client.hs view
@@ -3,30 +3,30 @@ -- Description: High-level interface to Gremlin Server -- Maintainer: Toshio Ito <debug.ito@gmail.com> ----- +-- module Network.Greskell.WebSocket.Client- ( -- * Make a Client- connect,- connectWith,- close,- Client,- Host,- Port,- -- ** Options for Client- module Network.Greskell.WebSocket.Client.Options,- -- * Submit evaluation requests- submit,- submitPair,- submitRaw,- ResultHandle,- nextResult,- nextResultSTM,- slurpResults,- drainResults,- -- * Exceptions- SubmitException(..)- ) where+ ( -- * Make a Client+ connect+ , connectWith+ , close+ , Client+ , Host+ , Port+ -- ** Options for Client+ , module Network.Greskell.WebSocket.Client.Options+ -- * Submit evaluation requests+ , submit+ , submitPair+ , submitRaw+ , ResultHandle+ , nextResult+ , nextResultSTM+ , slurpResults+ , drainResults+ -- * Exceptions+ , SubmitException (..)+ ) where -import Network.Greskell.WebSocket.Client.Impl-import Network.Greskell.WebSocket.Client.Options-import Network.Greskell.WebSocket.Connection (Host, Port)+import Network.Greskell.WebSocket.Client.Impl+import Network.Greskell.WebSocket.Client.Options+import Network.Greskell.WebSocket.Connection (Host, Port)
src/Network/Greskell/WebSocket/Client/Impl.hs view
@@ -1,53 +1,50 @@-{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE TypeFamilies #-} -- | -- Module: Network.Greskell.WebSocket.Client.Impl--- Description: +-- Description: -- Maintainer: Toshio Ito <debug.ito@gmail.com> -- -- __Internal module__. It's like -- "Network.Greskell.WebSocket.Connection.Impl".-module Network.Greskell.WebSocket.Client.Impl- where+module Network.Greskell.WebSocket.Client.Impl where -import Control.Applicative ((<$>), (<*>))-import Control.Concurrent.STM- ( STM, atomically,- TVar, newTVarIO, readTVar, writeTVar- )-import Control.Exception.Safe- ( throw, Typeable, Exception, SomeException, catch- )-import Data.Aeson (Object)-import qualified Data.Aeson as Aeson-import qualified Data.Aeson.Types as Aeson (Parser)-import Data.Greskell.Greskell (ToGreskell(GreskellReturn), toGremlin)-import Data.Greskell.GraphSON (GraphSON, gsonValue, GValue, FromGraphSON(..), parseEither)-import Data.Greskell.AsIterator (AsIterator(IteratorItem))-import Data.Monoid (mempty)-import Data.Vector (Vector, (!))-import Data.Text (Text)-import Data.Traversable (traverse)-import Data.Vector (Vector)+import Control.Applicative ((<$>), (<*>))+import Control.Concurrent.STM (STM, TVar, atomically, newTVarIO,+ readTVar, writeTVar)+import Control.Exception.Safe (Exception, SomeException, Typeable,+ catch, throw)+import Data.Aeson (Object)+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson (Parser)+import Data.Greskell.AsIterator (AsIterator (IteratorItem))+import Data.Greskell.GraphSON (FromGraphSON (..), GValue, GraphSON,+ gsonValue, parseEither)+import Data.Greskell.Greskell (ToGreskell (GreskellReturn),+ toGremlin)+import Data.Monoid (mempty)+import Data.Text (Text)+import Data.Traversable (traverse)+import Data.Vector (Vector, (!)) -import Network.Greskell.WebSocket.Client.Options (Options)-import qualified Network.Greskell.WebSocket.Client.Options as Opt-import Network.Greskell.WebSocket.Connection- ( Host, Port, Connection, ResponseHandle- )-import qualified Network.Greskell.WebSocket.Connection as Conn+import Network.Greskell.WebSocket.Client.Options (Options)+import qualified Network.Greskell.WebSocket.Client.Options as Opt+import Network.Greskell.WebSocket.Connection (Connection, Host, Port,+ ResponseHandle)+import qualified Network.Greskell.WebSocket.Connection as Conn import qualified Network.Greskell.WebSocket.Request.Standard as ReqStd-import Network.Greskell.WebSocket.Response (ResponseCode, ResponseMessage)-import qualified Network.Greskell.WebSocket.Response as Res-import Network.Greskell.WebSocket.Util (slurp, drain)+import Network.Greskell.WebSocket.Response (ResponseCode, ResponseMessage)+import qualified Network.Greskell.WebSocket.Response as Res+import Network.Greskell.WebSocket.Util (drain, slurp) -- | A client that establishes a connection to the Gremlin Server. You -- can send Gremlin expression for evaluation by 'submit' function.-data Client =- Client- { clientOpts :: Options,- clientConn :: Connection GValue- }+data Client+ = Client+ { clientOpts :: Options+ , clientConn :: Connection GValue+ } -- | Create a 'Client' to a Gremlin Server, with the default 'Options'. connect :: Host -> Port -> IO Client@@ -66,22 +63,22 @@ close :: Client -> IO () close c = Conn.close $ clientConn c -data HandleState =- HandleOpen+data HandleState+ = HandleOpen | HandleClose | HandleError SomeException deriving (Show) -- | A handle to receive the result of evaluation of a Gremlin script -- from the server.-data ResultHandle v =- ResultHandle- { rhResHandle :: ResponseHandle GValue,- rhParseGValue :: GValue -> Either String (Vector v),- rhResultCache :: TVar (Vector v),- rhNextResultIndex :: TVar Int,- rhState :: TVar HandleState- }+data ResultHandle v+ = ResultHandle+ { rhResHandle :: ResponseHandle GValue+ , rhParseGValue :: GValue -> Either String (Vector v)+ , rhResultCache :: TVar (Vector v)+ , rhNextResultIndex :: TVar Int+ , rhState :: TVar HandleState+ } submitBase :: FromGraphSON r => Client -> Text -> Maybe Object -> IO (ResultHandle r) submitBase client script bindings = do@@ -107,7 +104,7 @@ -- | Submit a Gremlin script to the server. You can get its results by -- 'ResultHandle'. The result type @v@ is determined by the script -- type @g@.--- +-- -- Usually this function does not throw any exception. Exceptions -- about sending requests are reported when you operate on -- 'ResultHandle'.@@ -136,14 +133,14 @@ submitRaw = submitBase -- | Exception about 'submit' operation and getting its result.-data SubmitException =- ResponseError (ResponseMessage GValue)- -- ^ The server returns a 'ResponseMessage' with error 'ResponseCode'.+data SubmitException+ = ResponseError (ResponseMessage GValue)+ -- ^ The server returns a 'ResponseMessage' with error 'ResponseCode'. | ParseError (ResponseMessage GValue) String- -- ^ The client fails to parse the \"data\" field of the- -- 'ResponseMessage'. The error message is kept in the 'String'- -- field.- deriving (Show,Typeable)+ -- ^ The client fails to parse the \"data\" field of the+ -- 'ResponseMessage'. The error message is kept in the 'String'+ -- field.+ deriving (Show, Typeable) instance Exception SubmitException @@ -165,27 +162,27 @@ cur_state <- readTVar $ rhState rh case cur_state of HandleError err -> throw err- HandleClose -> return Nothing- HandleOpen -> doNext `withExceptionSTM` gotoError+ HandleClose -> return Nothing+ HandleOpen -> doNext `withExceptionSTM` gotoError where doNext = do mret <- getNext case mret of Nothing -> writeTVar (rhState rh) HandleClose- _ -> return ()+ _ -> return () return mret getNext = do mnext <- getNextCachedResult rh case mnext of- Just v -> return $ Just v+ Just v -> return $ Just v Nothing -> loadResponse rh -- 'withException' function is for MonadMask and STM is not a -- MonadMask. So we use catch-and-rethrow by hand. withExceptionSTM main finish = main `catch` (\ex -> finish ex >> throw ex) gotoError ex = writeTVar (rhState rh) $ HandleError ex- + getNextCachedResult :: ResultHandle v -> STM (Maybe v) getNextCachedResult rh = do (cache, index) <- (,) <$> (readTVar $ rhResultCache rh) <*> (readTVar $ rhNextResultIndex rh)@@ -201,12 +198,12 @@ loadResponse rh = parseResponse =<< (Conn.nextResponseSTM $ rhResHandle rh) where parseResponse Nothing = return Nothing- parseResponse (Just res) = + parseResponse (Just res) = case Res.code $ Res.status res of- Res.Success -> parseData res- Res.NoContent -> return Nothing+ Res.Success -> parseData res+ Res.NoContent -> return Nothing Res.PartialContent -> parseData res- _ -> throw $ ResponseError res -- TODO: handle Authenticate code+ _ -> throw $ ResponseError res -- TODO: handle Authenticate code parseData res = case rhParseGValue rh $ Res.resultData $ Res.result res of Left err -> throw $ ParseError res err
src/Network/Greskell/WebSocket/Client/Options.hs view
@@ -3,49 +3,49 @@ -- Description: Options to create a Client -- Maintainer: Toshio Ito <debug.ito@gmail.com> ----- +-- module Network.Greskell.WebSocket.Client.Options- ( -- * Options- Options,- defOptions,- -- ** accessor functions- connectionSettings,- batchSize,- language,- aliases,- scriptEvaluationTimeout,- -- * Settings- module Network.Greskell.WebSocket.Connection.Settings- ) where+ ( -- * Options+ Options+ , defOptions+ -- ** accessor functions+ , connectionSettings+ , batchSize+ , language+ , aliases+ , scriptEvaluationTimeout+ -- * Settings+ , module Network.Greskell.WebSocket.Connection.Settings+ ) where -import Data.Greskell.GraphSON (GValue)-import Data.HashMap.Strict (HashMap)-import Data.Text (Text)+import Data.Greskell.GraphSON (GValue)+import Data.HashMap.Strict (HashMap)+import Data.Text (Text) -import Network.Greskell.WebSocket.Connection (Connection)-import Network.Greskell.WebSocket.Connection.Settings+import Network.Greskell.WebSocket.Connection (Connection)+import Network.Greskell.WebSocket.Connection.Settings -- | Configuration options to create a client for Gremlin Server. -- -- You can get the default 'Options' by 'defOptions' function, and -- customize its fields by accessor functions.-data Options =- Options- { connectionSettings :: !(Settings GValue),- -- ^ Settings for the underlying 'Connection'. Default:- -- 'defJSONSettings'.- batchSize :: !(Maybe Int),- -- ^ \"batchSize\" field for \"eval\" operation. Default:- -- 'Nothing'.- language :: !(Maybe Text),- -- ^ \"language\" field for \"eval\" operation. Default:- -- 'Nothing'.- aliases :: !(Maybe (HashMap Text Text)),- -- ^ \"aliases\" field for \"eval\" operation. Default: 'Nothing'.- scriptEvaluationTimeout :: !(Maybe Int)- -- ^ \"scriptEvaluationTimeout\" field for \"eval\"- -- operation. Default: 'Nothing'.- }+data Options+ = Options+ { connectionSettings :: !(Settings GValue)+ -- ^ Settings for the underlying 'Connection'. Default:+ -- 'defJSONSettings'.+ , batchSize :: !(Maybe Int)+ -- ^ \"batchSize\" field for \"eval\" operation. Default:+ -- 'Nothing'.+ , language :: !(Maybe Text)+ -- ^ \"language\" field for \"eval\" operation. Default:+ -- 'Nothing'.+ , aliases :: !(Maybe (HashMap Text Text))+ -- ^ \"aliases\" field for \"eval\" operation. Default: 'Nothing'.+ , scriptEvaluationTimeout :: !(Maybe Int)+ -- ^ \"scriptEvaluationTimeout\" field for \"eval\"+ -- operation. Default: 'Nothing'.+ } defOptions :: Options defOptions =
src/Network/Greskell/WebSocket/Codec.hs view
@@ -3,36 +3,39 @@ -- Description: Encoder\/decoder of Request\/Response -- Maintainer: Toshio Ito <debug.ito@gmail.com> ----- +-- module Network.Greskell.WebSocket.Codec- ( -- * Codec- Codec(..),- -- * Request encoder- encodeBinaryWith,- messageHeader,- -- * Request decoder- decodeBinary- ) where+ ( -- * Codec+ Codec (..)+ -- * Request encoder+ , encodeBinaryWith+ , messageHeader+ -- * Request decoder+ , decodeBinary+ ) where -import Control.Monad (when)-import qualified Data.ByteString.Lazy as BSL-import Data.Monoid ((<>))-import Data.Text (Text)-import Data.Text.Encoding (encodeUtf8, decodeUtf8')+import Control.Monad (when)+import qualified Data.ByteString.Lazy as BSL+import Data.Monoid ((<>))+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8', encodeUtf8) -import Network.Greskell.WebSocket.Request (RequestMessage)-import Network.Greskell.WebSocket.Response (ResponseMessage)+import Network.Greskell.WebSocket.Request (RequestMessage)+import Network.Greskell.WebSocket.Response (ResponseMessage) -- | Encoder of 'RequestMessage' and decoder of 'ResponseMessage', -- associated with a MIME type. -- -- Type @s@ is the body of Response.-data Codec s =- Codec- { mimeType :: Text, -- ^ MIME type sent to the server- encodeWith :: RequestMessage -> BSL.ByteString, -- ^ Request encoder- decodeWith :: BSL.ByteString -> Either String (ResponseMessage s) -- ^ Response decoder- }+data Codec s+ = Codec+ { mimeType :: Text+ -- ^ MIME type sent to the server+ , encodeWith :: RequestMessage -> BSL.ByteString+ -- ^ Request encoder+ , decodeWith :: BSL.ByteString -> Either String (ResponseMessage s)+ -- ^ Response decoder+ } instance Functor Codec where fmap f c = c { decodeWith = (fmap . fmap . fmap) f $ decodeWith c }@@ -57,7 +60,7 @@ -> Either String (Text, BSL.ByteString) -- ^ (mimeType, payload) decodeBinary raw_msg = do case BSL.uncons raw_msg of- Nothing -> Left "Length of MIME type is missing in the header."+ Nothing -> Left "Length of MIME type is missing in the header." Just (mime_len, rest) -> decodeMimeAndPayload mime_len rest where decodeMimeAndPayload mime_lenw msg = do
src/Network/Greskell/WebSocket/Codec/JSON.hs view
@@ -4,18 +4,18 @@ -- Description: application\/json codec -- Maintainer: Toshio Ito <debug.ito@gmail.com> ----- +-- module Network.Greskell.WebSocket.Codec.JSON- ( jsonCodec- ) where+ ( jsonCodec+ ) where -import Data.Aeson (ToJSON, FromJSON)-import qualified Data.Aeson as A-import Data.Aeson.Types (parseEither)+import Data.Aeson (FromJSON, ToJSON)+import qualified Data.Aeson as A+import Data.Aeson.Types (parseEither) -import Data.Greskell.GraphSON (FromGraphSON(..))+import Data.Greskell.GraphSON (FromGraphSON (..)) -import Network.Greskell.WebSocket.Codec (Codec(..))+import Network.Greskell.WebSocket.Codec (Codec (..)) -- | Simple \"application\/json\" codec. --
src/Network/Greskell/WebSocket/Connection.hs view
@@ -3,29 +3,29 @@ -- Description: WebSocket Connection to Gremlin Server -- Maintainer: Toshio Ito <debug.ito@gmail.com> ----- +-- module Network.Greskell.WebSocket.Connection- ( -- * Make a Connection- connect,- close,- Connection,- Host,- Port,- -- ** Settings for Connection- module Network.Greskell.WebSocket.Connection.Settings,- -- * Make a request- sendRequest,- sendRequest',- ResponseHandle,- nextResponse,- nextResponseSTM,- slurpResponses,- drainResponses,- -- * Exceptions- GeneralException(..),- RequestException(..)- ) where+ ( -- * Make a Connection+ connect+ , close+ , Connection+ , Host+ , Port+ -- ** Settings for Connection+ , module Network.Greskell.WebSocket.Connection.Settings+ -- * Make a request+ , sendRequest+ , sendRequest'+ , ResponseHandle+ , nextResponse+ , nextResponseSTM+ , slurpResponses+ , drainResponses+ -- * Exceptions+ , GeneralException (..)+ , RequestException (..)+ ) where -import Network.Greskell.WebSocket.Connection.Impl-import Network.Greskell.WebSocket.Connection.Settings-import Network.Greskell.WebSocket.Connection.Type+import Network.Greskell.WebSocket.Connection.Impl+import Network.Greskell.WebSocket.Connection.Settings+import Network.Greskell.WebSocket.Connection.Type
src/Network/Greskell/WebSocket/Connection/Impl.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE DuplicateRecordFields, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE TypeApplications #-} -- | -- Module: Network.Greskell.WebSocket.Connection.Impl -- Description: internal implementation of Connection@@ -8,50 +11,50 @@ -- upper module is responsible to make a proper export list. module Network.Greskell.WebSocket.Connection.Impl where -import Control.Applicative ((<$>), (<|>), empty)-import Control.Concurrent (threadDelay)-import Control.Concurrent.Async (withAsync, Async, async, waitCatchSTM, waitAnySTM)-import qualified Control.Concurrent.Async as Async-import Control.Concurrent.STM- ( TBQueue, readTBQueue, newTBQueueIO, writeTBQueue,- TQueue, writeTQueue, newTQueueIO, readTQueue,- TVar, newTVarIO, readTVar, writeTVar,- TMVar, tryPutTMVar, tryReadTMVar, putTMVar, newEmptyTMVarIO, readTMVar,- STM, atomically, retry- )-import qualified Control.Concurrent.STM as STM-import Control.Exception.Safe- ( Exception(toException), SomeException, withException, throw, try, finally- )-import Control.Monad (when, void, forM_)-import Data.Aeson (Value)-import qualified Data.ByteString.Lazy as BSL-import Data.Foldable (toList)-import qualified Data.HashTable.IO as HT-import Data.Monoid (mempty)-import Data.Typeable (Typeable)-import Data.UUID (UUID)-import Data.Vector (Vector)-import qualified Network.WebSockets as WS+import Control.Applicative (empty, (<$>), (<|>))+import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (Async, async, waitAnySTM,+ waitCatchSTM, withAsync)+import qualified Control.Concurrent.Async as Async+import Control.Concurrent.STM (STM, TBQueue, TMVar, TQueue, TVar,+ atomically, newEmptyTMVarIO,+ newTBQueueIO, newTQueueIO,+ newTVarIO, putTMVar, readTBQueue,+ readTMVar, readTQueue, readTVar,+ retry, tryPutTMVar, tryReadTMVar,+ writeTBQueue, writeTQueue,+ writeTVar)+import qualified Control.Concurrent.STM as STM+import Control.Exception.Safe (Exception (toException),+ SomeException, finally, throw, try,+ withException)+import Control.Monad (forM_, void, when)+import Data.Aeson (Value)+import qualified Data.ByteString.Lazy as BSL+import Data.Foldable (toList)+import qualified Data.HashTable.IO as HT+import Data.Monoid (mempty)+import Data.Typeable (Typeable)+import Data.UUID (UUID)+import Data.Vector (Vector)+import GHC.Records (HasField (..))+import qualified Network.WebSockets as WS -import Network.Greskell.WebSocket.Codec (Codec(decodeWith, encodeWith), encodeBinaryWith)-import Network.Greskell.WebSocket.Connection.Settings (Settings)+import Network.Greskell.WebSocket.Codec (Codec (decodeWith, encodeWith),+ encodeBinaryWith)+import Network.Greskell.WebSocket.Connection.Settings (Settings) import qualified Network.Greskell.WebSocket.Connection.Settings as Settings-import Network.Greskell.WebSocket.Connection.Type- ( Connection(..), ConnectionState(..),- ResPack, ReqID, ReqPack(..), RawRes,- GeneralException(..)- )-import Network.Greskell.WebSocket.Request- ( RequestMessage(RequestMessage, requestId),- Operation, makeRequestMessage- )-import Network.Greskell.WebSocket.Response- ( ResponseMessage(ResponseMessage, requestId, status),- ResponseStatus(ResponseStatus, code),- isTerminating- )-import Network.Greskell.WebSocket.Util (slurp, drain)+import Network.Greskell.WebSocket.Connection.Type (Connection (..),+ ConnectionState (..),+ GeneralException (..), RawRes,+ ReqID, ReqPack (..), ResPack)+import Network.Greskell.WebSocket.Request (Operation,+ RequestMessage (RequestMessage, requestId),+ makeRequestMessage)+import Network.Greskell.WebSocket.Response (ResponseMessage (ResponseMessage, requestId, status),+ ResponseStatus (ResponseStatus, code),+ isTerminating)+import Network.Greskell.WebSocket.Util (drain, slurp) flushTBQueue :: TBQueue a -> STM [a]@@ -96,7 +99,7 @@ -- -- If there are pending requests in the 'Connection', 'close' function -- blocks for them to complete or time out.--- +-- -- Calling 'close' on a 'Connection' already closed (or waiting to -- close) does nothing. close :: Connection s -> IO ()@@ -116,7 +119,7 @@ if cur_state == ConnClosed then return () else retry- + type Path = String -- | A thread taking care of a WS connection.@@ -135,7 +138,7 @@ else setupMux wsconn setupMux wsconn = do qres <- newTQueueIO- withAsync (runRxLoop wsconn qres) $ \rx_thread -> + withAsync (runRxLoop wsconn qres) $ \rx_thread -> runMuxLoop wsconn req_pool settings qreq qres (readTVar var_conn_state) rx_thread checkAndReportConnectSuccess = atomically $ do mret <- tryReadTMVar var_connect_result@@ -169,40 +172,41 @@ reportToReqPack reqp = writeTQueue (reqOutput reqp) $ Left cause -- | An exception related to a specific request.-data RequestException =- AlreadyClosed- -- ^ The connection is already closed before it sends the request.+data RequestException+ = AlreadyClosed+ -- ^ The connection is already closed before it sends the request. | ServerClosed- -- ^ The server closed the connection before it sends response for- -- this request.+ -- ^ The server closed the connection before it sends response for+ -- this request. | DuplicateRequestId UUID- -- ^ The requestId (kept in this object) is already pending in the- -- connection.+ -- ^ The requestId (kept in this object) is already pending in the+ -- connection. | ResponseTimeout- -- ^ The server fails to send ResponseMessages within- -- 'Settings.responseTimeout'.- deriving (Show,Eq,Typeable)+ -- ^ The server fails to send ResponseMessages within+ -- 'Settings.responseTimeout'.+ deriving (Eq, Show, Typeable) instance Exception RequestException -data ReqPoolEntry s =- ReqPoolEntry- { rpeReqId :: !ReqID,- rpeOutput :: !(TQueue (ResPack s)),- rpeTimer :: !(Async ReqID)- -- ^ timer thread to time out response.- }+data ReqPoolEntry s+ = ReqPoolEntry+ { rpeReqId :: !ReqID+ , rpeOutput :: !(TQueue (ResPack s))+ , rpeTimer :: !(Async ReqID)+ -- ^ timer thread to time out response.+ } -- | (requestId of pending request) --> (objects related to that pending request) type ReqPool s = HT.BasicHashTable ReqID (ReqPoolEntry s) -- | Multiplexed event object-data MuxEvent s = EvReq (ReqPack s)- | EvRes RawRes- | EvActiveClose- | EvRxFinish- | EvRxError SomeException- | EvResponseTimeout ReqID+data MuxEvent s+ = EvReq (ReqPack s)+ | EvRes RawRes+ | EvActiveClose+ | EvRxFinish+ | EvRxError SomeException+ | EvResponseTimeout ReqID -- | HashTable's mutateIO is available since 1.2.3.0 tryInsertToReqPool :: ReqPool s@@ -248,17 +252,17 @@ res_timers <- getAllResponseTimers req_pool event <- atomically $ getEventSTM res_timers case event of- EvReq req -> handleReq req >> loop- EvRes res -> handleRes res >> loop- EvActiveClose -> return ()- EvRxFinish -> handleRxFinish- EvRxError e -> throw e+ EvReq req -> handleReq req >> loop+ EvRes res -> handleRes res >> loop+ EvActiveClose -> return ()+ EvRxFinish -> handleRxFinish+ EvRxError e -> throw e EvResponseTimeout rid -> handleResponseTimeout rid >> loop getEventSTM res_timers = getRequest <|> (EvRes <$> readTQueue qres) <|> makeEvActiveClose <|> (rxResultToEvent <$> waitCatchSTM rx_thread)- <|> (timeoutToEvent <$> waitAnySTM res_timers)+ <|> waitResponseTimeout res_timers where max_concurrency = Settings.concurrency settings cur_concurrency = length res_timers@@ -266,7 +270,7 @@ then EvReq <$> readTBQueue qreq else empty rxResultToEvent (Right ()) = EvRxFinish- rxResultToEvent (Left e) = EvRxError e+ rxResultToEvent (Left e) = EvRxError e timeoutToEvent (_, rid) = EvResponseTimeout rid makeEvActiveClose = do if cur_concurrency > 0@@ -274,6 +278,10 @@ else do conn_state <- readConnState if conn_state == ConnOpen then empty else return EvActiveClose+ waitResponseTimeout timers =+ if null timers+ then empty+ else timeoutToEvent <$> waitAnySTM timers handleReq req = do insert_ok <- tryInsertToReqPool req_pool rid makeNewEntry if insert_ok@@ -291,7 +299,7 @@ reportError = atomically $ writeTQueue qout $ Left $ toException $ DuplicateRequestId rid handleRes res = case decodeWith codec res of- Left err -> Settings.onGeneralException settings $ ResponseParseFailure err+ Left err -> Settings.onGeneralException settings $ ResponseParseFailure err Right res_msg -> handleResMsg res_msg handleResMsg res_msg@(ResponseMessage { requestId = rid }) = do m_entry <- HT.lookup req_pool rid@@ -344,17 +352,17 @@ runTimer wait_sec rid = async $ do threadDelay $ wait_sec * 1000000 return rid- + -- | A handle associated in a 'Connection' for a pair of request and -- response. You can retrieve 'ResponseMessage's from this object. -- -- Type @s@ is the body of the response.-data ResponseHandle s =- ResponseHandle- { rhGetResponse :: STM (ResPack s),- rhTerminated :: TVar Bool- }+data ResponseHandle s+ = ResponseHandle+ { rhGetResponse :: STM (ResPack s)+ , rhTerminated :: TVar Bool+ } instance Functor ResponseHandle where fmap f rh = rh { rhGetResponse = (fmap . fmap . fmap) f $ rhGetResponse rh }@@ -382,7 +390,7 @@ codec = connCodec conn qreq = connQReq conn var_conn_state = connState conn- rid = requestId (req_msg :: RequestMessage)+ rid = getField @"requestId" req_msg getConnectionOpen = fmap (== ConnOpen) $ atomically $ readTVar var_conn_state sendReqPack qout = do atomically $ writeTBQueue qreq reqpack@@ -400,7 +408,7 @@ } reportAlreadyClosed qout = do atomically $ writeTQueue qout $ Left $ toException $ AlreadyClosed- + -- | Get a 'ResponseMessage' from 'ResponseHandle'. If you have -- already got all responses, it returns 'Nothing'. This function may
src/Network/Greskell/WebSocket/Connection/Settings.hs view
@@ -3,24 +3,28 @@ -- Description: Settings for making Connection -- Maintainer: Toshio Ito <debug.ito@gmail.com> ----- +-- module Network.Greskell.WebSocket.Connection.Settings- ( -- * Settings- Settings,- defSettings,- defJSONSettings,- -- ** accessor functions- codec, endpointPath, onGeneralException, responseTimeout,- concurrency, requestQueueSize- ) where+ ( -- * Settings+ Settings+ , defSettings+ , defJSONSettings+ -- ** accessor functions+ , codec+ , endpointPath+ , onGeneralException+ , responseTimeout+ , concurrency+ , requestQueueSize+ ) where -import Data.Greskell.GraphSON (FromGraphSON)+import Data.Greskell.GraphSON (FromGraphSON) -import Network.Greskell.WebSocket.Codec (Codec)-import Network.Greskell.WebSocket.Codec.JSON (jsonCodec)-import Network.Greskell.WebSocket.Connection.Type (GeneralException)+import Network.Greskell.WebSocket.Codec (Codec)+import Network.Greskell.WebSocket.Codec.JSON (jsonCodec)+import Network.Greskell.WebSocket.Connection.Type (GeneralException) -import System.IO (stderr, hPutStrLn)+import System.IO (hPutStrLn, stderr) -- | 'Settings' for making connection to Gremlin Server. --@@ -28,33 +32,33 @@ -- customize its fields by accessor functions. -- -- Type @s@ is the body of Response.-data Settings s =- Settings- { codec :: !(Codec s),- -- ^ codec for the connection.- endpointPath :: !String,- -- ^ Path of the WebSocket endpoint. Default: \"/gremlin\"- onGeneralException :: !(GeneralException -> IO ()),- -- ^ An exception handler for 'GeneralException'. This exception- -- is not fatal, so the connection survives after this handler is- -- called. You don't have to re-throw the exception. Default:- -- print the exception to stderr.- responseTimeout :: !Int,- -- ^ Time out (in seconds) for responses. It is the maximum time- -- for which the connection waits for a response to complete after- -- it sends a request. If the response consists of more than one- -- ResponseMessages, the timeout applies to the last of the- -- ResponseMessages. Default: 60- concurrency :: !Int,- -- ^ Maximum concurrent requests the connection can make to the- -- server. If the client tries to make more concurrent requests- -- than this value, later requests are queued in the connection or- -- the client may be blocked. Default: 4- requestQueueSize :: !Int- -- ^ Size of the internal queue of requests. Usually you don't- -- need to customize the field. See also 'concurrency'. Default:- -- 8.- }+data Settings s+ = Settings+ { codec :: !(Codec s)+ -- ^ codec for the connection.+ , endpointPath :: !String+ -- ^ Path of the WebSocket endpoint. Default: \"/gremlin\"+ , onGeneralException :: !(GeneralException -> IO ())+ -- ^ An exception handler for 'GeneralException'. This exception+ -- is not fatal, so the connection survives after this handler is+ -- called. You don't have to re-throw the exception. Default:+ -- print the exception to stderr.+ , responseTimeout :: !Int+ -- ^ Time out (in seconds) for responses. It is the maximum time+ -- for which the connection waits for a response to complete after+ -- it sends a request. If the response consists of more than one+ -- ResponseMessages, the timeout applies to the last of the+ -- ResponseMessages. Default: 60+ , concurrency :: !Int+ -- ^ Maximum concurrent requests the connection can make to the+ -- server. If the client tries to make more concurrent requests+ -- than this value, later requests are queued in the connection or+ -- the client may be blocked. Default: 4+ , requestQueueSize :: !Int+ -- ^ Size of the internal queue of requests. Usually you don't+ -- need to customize the field. See also 'concurrency'. Default:+ -- 8.+ } defSettings :: Codec s -> Settings s defSettings c = Settings
src/Network/Greskell/WebSocket/Connection/Type.hs view
@@ -7,24 +7,24 @@ -- used by Connection modules. The upper module is responsible to -- limit exports from this module. module Network.Greskell.WebSocket.Connection.Type- ( RawReq,- RawRes,- ReqID,- ResPack,- ReqPack(..),- ConnectionState(..),- Connection(..),- GeneralException(..)- ) where+ ( RawReq+ , RawRes+ , ReqID+ , ResPack+ , ReqPack (..)+ , ConnectionState (..)+ , Connection (..)+ , GeneralException (..)+ ) where -import Control.Concurrent.Async (Async)-import Control.Exception.Safe (SomeException, Typeable, Exception)-import Control.Concurrent.STM (TQueue, TBQueue, TVar)-import qualified Data.ByteString.Lazy as BSL-import Data.UUID (UUID)+import Control.Concurrent.Async (Async)+import Control.Concurrent.STM (TBQueue, TQueue, TVar)+import Control.Exception.Safe (Exception, SomeException, Typeable)+import qualified Data.ByteString.Lazy as BSL+import Data.UUID (UUID) -import Network.Greskell.WebSocket.Response (ResponseMessage)-import Network.Greskell.WebSocket.Codec (Codec)+import Network.Greskell.WebSocket.Codec (Codec)+import Network.Greskell.WebSocket.Response (ResponseMessage) type RawReq = BSL.ByteString type RawRes = BSL.ByteString@@ -35,54 +35,54 @@ -- | Package of request data and related stuff. It's passed from the -- caller thread into WS handling thread.-data ReqPack s = - ReqPack- { reqData :: !RawReq,- -- ^ Encoded request data- reqId :: !ReqID,- -- ^ request ID- reqOutput :: !(TQueue (ResPack s))- -- ^ the output queue for incoming response for this request.- }+data ReqPack s+ = ReqPack+ { reqData :: !RawReq+ -- ^ Encoded request data+ , reqId :: !ReqID+ -- ^ request ID+ , reqOutput :: !(TQueue (ResPack s))+ -- ^ the output queue for incoming response for this request.+ } -- | State of the 'Connection'.-data ConnectionState =- ConnOpen- -- ^ Connection is open and ready to use.+data ConnectionState+ = ConnOpen+ -- ^ Connection is open and ready to use. | ConnClosing- -- ^ Connection is closing. It rejects new requests, but keeps- -- receiving responses for pending requests. When there is no- -- pending requests, it goes to 'ConnClosed'.+ -- ^ Connection is closing. It rejects new requests, but keeps+ -- receiving responses for pending requests. When there is no+ -- pending requests, it goes to 'ConnClosed'. | ConnClosed- -- ^ Connection is closed. It rejects requests, and it doesn't- -- expect any responses. It can close the underlying WebSocket- -- connection.- deriving (Show,Eq,Ord,Enum,Bounded)+ -- ^ Connection is closed. It rejects requests, and it doesn't+ -- expect any responses. It can close the underlying WebSocket+ -- connection.+ deriving (Bounded, Enum, Eq, Ord, Show) -- | A WebSocket connection to a Gremlin Server. -- -- Type @s@ is the body of Response, as in 'ResponseMessage'.-data Connection s =- Connection- { connQReq :: !(TBQueue (ReqPack s)),- -- ^ Request queue to WS (Mux) thread.- connState :: !(TVar ConnectionState),- connWSThread :: !(Async ()),- -- ^ WS (Mux) thread. It keeps the underlying WebSocket- -- connection, watches various types of events and responds to- -- those events.- connCodec :: !(Codec s)- }+data Connection s+ = Connection+ { connQReq :: !(TBQueue (ReqPack s))+ -- ^ Request queue to WS (Mux) thread.+ , connState :: !(TVar ConnectionState)+ , connWSThread :: !(Async ())+ -- ^ WS (Mux) thread. It keeps the underlying WebSocket+ -- connection, watches various types of events and responds to+ -- those events.+ , connCodec :: !(Codec s)+ } -- | Exception general to a 'Connection'. It's not related to specific -- requests.-data GeneralException =- UnexpectedRequestId UUID- -- ^ Server sends a 'ResponseMessage' with unknown requestId, which- -- is kept in this exception.+data GeneralException+ = UnexpectedRequestId UUID+ -- ^ Server sends a 'ResponseMessage' with unknown requestId, which+ -- is kept in this exception. | ResponseParseFailure String- -- ^ The 'Connection' fails to parse a data from the server. The- -- error message is kept in this exception.- deriving (Show,Eq,Typeable)+ -- ^ The 'Connection' fails to parse a data from the server. The+ -- error message is kept in this exception.+ deriving (Eq, Show, Typeable) instance Exception GeneralException
src/Network/Greskell/WebSocket/Request.hs view
@@ -1,39 +1,40 @@-{-# LANGUAGE DuplicateRecordFields, DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-} -- | -- Module: Network.Greskell.WebSocket.Request -- Description: Request to Gremlin Server -- Maintainer: Toshio Ito <debug.ito@gmail.com> ----- +-- module Network.Greskell.WebSocket.Request- ( -- * RequestMessage- RequestMessage(..),- Operation(..),- toRequestMessage,- makeRequestMessage- ) where+ ( -- * RequestMessage+ RequestMessage (..)+ , Operation (..)+ , toRequestMessage+ , makeRequestMessage+ ) where -import Control.Applicative ((<$>), (<*>))-import Data.Aeson (Object, ToJSON(..), FromJSON(..))-import Data.Text (Text)-import Data.UUID (UUID)-import Data.UUID.V4 (nextRandom)-import GHC.Generics (Generic)+import Control.Applicative ((<$>), (<*>))+import Data.Aeson (FromJSON (..), Object, ToJSON (..))+import Data.Text (Text)+import Data.UUID (UUID)+import Data.UUID.V4 (nextRandom)+import GHC.Generics (Generic) -import qualified Network.Greskell.WebSocket.Request.Aeson as GAeson-import Network.Greskell.WebSocket.Request.Common (Operation(..))+import qualified Network.Greskell.WebSocket.Request.Aeson as GAeson+import Network.Greskell.WebSocket.Request.Common (Operation (..)) -- | RequestMessage to a Gremlin Server. See -- <http://tinkerpop.apache.org/docs/current/dev/provider/>.-data RequestMessage =- RequestMessage- { requestId :: !UUID,- op :: !Text,- processor :: !Text,- args :: !Object- }- deriving (Show,Eq,Generic)+data RequestMessage+ = RequestMessage+ { requestId :: !UUID+ , op :: !Text+ , processor :: !Text+ , args :: !Object+ }+ deriving (Eq, Generic, Show) instance ToJSON RequestMessage where toJSON = GAeson.genericToJSON GAeson.opt
src/Network/Greskell/WebSocket/Request/Aeson.hs view
@@ -5,18 +5,16 @@ -- -- __Internal module. End-users should not use this.__ module Network.Greskell.WebSocket.Request.Aeson- ( genericToJSON, genericToEncoding, genericParseJSON,- opt,- toObject- ) where+ ( genericToJSON+ , genericToEncoding+ , genericParseJSON+ , opt+ , toObject+ ) where -import Data.Aeson- ( genericToJSON, genericToEncoding, genericParseJSON,- ToJSON(..), Object, Value(Object)- )-import Data.Aeson.Types - ( defaultOptions, omitNothingFields, Options- )+import Data.Aeson (Object, ToJSON (..), Value (Object), genericParseJSON,+ genericToEncoding, genericToJSON)+import Data.Aeson.Types (Options, defaultOptions, omitNothingFields) opt :: Options opt = defaultOptions { omitNothingFields = True }@@ -25,4 +23,4 @@ toObject = expectObject . toJSON where expectObject (Object o) = o- expectObject _ = error "Expect Object, but got something else"+ expectObject _ = error "Expect Object, but got something else"
src/Network/Greskell/WebSocket/Request/Common.hs view
@@ -4,19 +4,19 @@ -- Description: Common data types for Request objects -- Maintainer: Toshio Ito <debug.ito@gmail.com> ----- +-- module Network.Greskell.WebSocket.Request.Common- ( Operation(..),- SASLMechanism(..),- Base64(..)- ) where+ ( Operation (..)+ , SASLMechanism (..)+ , Base64 (..)+ ) where -import Control.Applicative (empty)-import Data.Aeson (ToJSON(..), FromJSON(..), Object, Value(String))-import Data.ByteString (ByteString)+import Control.Applicative (empty)+import Data.Aeson (FromJSON (..), Object, ToJSON (..), Value (String))+import Data.ByteString (ByteString) import qualified Data.ByteString.Base64 as B64-import Data.Text (unpack, Text)-import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Text (Text, unpack)+import Data.Text.Encoding (decodeUtf8, encodeUtf8) -- | Class of operation objects.@@ -35,35 +35,37 @@ -- | Possible SASL mechanisms.-data SASLMechanism = SASLPlain -- ^ \"PLAIN\" SASL- | SASLGSSAPI -- ^ \"GSSAPI\" SASL- deriving (Show,Eq,Ord,Enum,Bounded)+data SASLMechanism+ = SASLPlain -- ^ \"PLAIN\" SASL+ | SASLGSSAPI -- ^ \"GSSAPI\" SASL+ deriving (Bounded, Enum, Eq, Ord, Show) instance ToJSON SASLMechanism where toJSON = toJSON . toText where toText :: SASLMechanism -> Text- toText SASLPlain = "PLAIN"+ toText SASLPlain = "PLAIN" toText SASLGSSAPI = "GSSAPI" instance FromJSON SASLMechanism where parseJSON (String s) = case s of- "PLAIN" -> return SASLPlain+ "PLAIN" -> return SASLPlain "GSSAPI" -> return SASLGSSAPI- _ -> fail ("Unknown SASLMechanism: " ++ unpack s)+ _ -> fail ("Unknown SASLMechanism: " ++ unpack s) parseJSON _ = empty -- | A raw 'ByteString' encoded to\/decoded from a base64 text. -- -- 'ToJSON' instance encodes the raw 'ByteString' to a base64-encoded -- 'Text'. 'FromJSON' is its inverse.-newtype Base64 = Base64 { unByte64 :: ByteString }- deriving (Show,Eq,Ord)+newtype Base64+ = Base64 { unByte64 :: ByteString }+ deriving (Eq, Ord, Show) instance ToJSON Base64 where toJSON (Base64 bs) = toJSON $ decodeUtf8 $ B64.encode bs instance FromJSON Base64 where parseJSON (String t) = either fail (return . Base64) $ B64.decode $ encodeUtf8 t- parseJSON _ = empty+ parseJSON _ = empty
src/Network/Greskell/WebSocket/Request/Session.hs view
@@ -1,37 +1,38 @@-{-# LANGUAGE DeriveGeneric, DuplicateRecordFields, OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-} -- | -- Module: Network.Greskell.WebSocket.Request.Session -- Description: Operation objects for session OpProcessor -- Maintainer: Toshio Ito <debug.ito@gmail.com> ----- +-- module Network.Greskell.WebSocket.Request.Session- ( -- * OpAuthentication- OpAuthentication(..),- -- * OpEval- SessionID,- OpEval(..),- -- * OpClose- OpClose(..)- ) where+ ( -- * OpAuthentication+ OpAuthentication (..)+ -- * OpEval+ , SessionID+ , OpEval (..)+ -- * OpClose+ , OpClose (..)+ ) where -import Data.Aeson (ToJSON(..), FromJSON(..), Object)-import Data.UUID (UUID)-import Data.Text (Text)-import Data.HashMap.Strict (HashMap)-import GHC.Generics (Generic)+import Data.Aeson (FromJSON (..), Object, ToJSON (..))+import Data.HashMap.Strict (HashMap)+import Data.Text (Text)+import Data.UUID (UUID)+import GHC.Generics (Generic) -import qualified Network.Greskell.WebSocket.Request.Aeson as GAeson-import Network.Greskell.WebSocket.Request.Common- (Base64, SASLMechanism, Operation(..))+import qualified Network.Greskell.WebSocket.Request.Aeson as GAeson+import Network.Greskell.WebSocket.Request.Common (Base64, Operation (..), SASLMechanism) -data OpAuthentication =- OpAuthentication- { batchSize :: !(Maybe Int),- sasl :: !Base64,- saslMechanism :: !SASLMechanism- }- deriving (Show,Eq,Ord,Generic)+data OpAuthentication+ = OpAuthentication+ { batchSize :: !(Maybe Int)+ , sasl :: !Base64+ , saslMechanism :: !SASLMechanism+ }+ deriving (Eq, Generic, Ord, Show) instance ToJSON OpAuthentication where toJSON = GAeson.genericToJSON GAeson.opt@@ -48,18 +49,18 @@ type SessionID = UUID -data OpEval =- OpEval- { batchSize :: !(Maybe Int),- gremlin :: !Text,- bindings :: !(Maybe Object),- language :: !(Maybe Text),- aliases :: !(Maybe (HashMap Text Text)),- scriptEvaluationTimeout :: !(Maybe Int),- session :: !SessionID,- manageTransaction :: !(Maybe Bool)- }- deriving (Show,Eq,Generic)+data OpEval+ = OpEval+ { batchSize :: !(Maybe Int)+ , gremlin :: !Text+ , bindings :: !(Maybe Object)+ , language :: !(Maybe Text)+ , aliases :: !(Maybe (HashMap Text Text))+ , scriptEvaluationTimeout :: !(Maybe Int)+ , session :: !SessionID+ , manageTransaction :: !(Maybe Bool)+ }+ deriving (Eq, Generic, Show) instance ToJSON OpEval where toJSON = GAeson.genericToJSON GAeson.opt@@ -74,13 +75,13 @@ opArgs = GAeson.toObject -data OpClose =- OpClose- { batchSize :: !(Maybe Int),- session :: !SessionID,- force :: !(Maybe Bool)- }- deriving (Show,Eq,Ord,Generic)+data OpClose+ = OpClose+ { batchSize :: !(Maybe Int)+ , session :: !SessionID+ , force :: !(Maybe Bool)+ }+ deriving (Eq, Generic, Ord, Show) instance ToJSON OpClose where toJSON = GAeson.genericToJSON GAeson.opt
src/Network/Greskell/WebSocket/Request/Standard.hs view
@@ -1,33 +1,34 @@-{-# LANGUAGE DeriveGeneric, DuplicateRecordFields, OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-} -- | -- Module: Network.Greskell.WebSocket.Request.Standard -- Description: Operation objects for standard OpProcessor -- Maintainer: Toshio Ito <debug.ito@gmail.com> ----- +-- module Network.Greskell.WebSocket.Request.Standard- ( -- * OpAuthentication- OpAuthentication(..),- -- * OpEval- OpEval(..)- ) where+ ( -- * OpAuthentication+ OpAuthentication (..)+ -- * OpEval+ , OpEval (..)+ ) where -import Data.Aeson (ToJSON(..), FromJSON(..), Object)-import Data.Text (Text)-import Data.HashMap.Strict (HashMap)-import GHC.Generics (Generic)+import Data.Aeson (FromJSON (..), Object, ToJSON (..))+import Data.HashMap.Strict (HashMap)+import Data.Text (Text)+import GHC.Generics (Generic) -import qualified Network.Greskell.WebSocket.Request.Aeson as GAeson-import Network.Greskell.WebSocket.Request.Common- (Base64, SASLMechanism, Operation(..))+import qualified Network.Greskell.WebSocket.Request.Aeson as GAeson+import Network.Greskell.WebSocket.Request.Common (Base64, Operation (..), SASLMechanism) -data OpAuthentication =- OpAuthentication- { batchSize :: !(Maybe Int),- sasl :: !Base64,- saslMechanism :: !SASLMechanism- }- deriving (Show,Eq,Ord,Generic)+data OpAuthentication+ = OpAuthentication+ { batchSize :: !(Maybe Int)+ , sasl :: !Base64+ , saslMechanism :: !SASLMechanism+ }+ deriving (Eq, Generic, Ord, Show) instance ToJSON OpAuthentication where toJSON = GAeson.genericToJSON GAeson.opt@@ -41,16 +42,16 @@ opName _ = "authentication" opArgs = GAeson.toObject -data OpEval =- OpEval- { batchSize :: !(Maybe Int),- gremlin :: !Text,- bindings :: !(Maybe Object),- language :: !(Maybe Text),- aliases :: !(Maybe (HashMap Text Text)),- scriptEvaluationTimeout :: !(Maybe Int)- }- deriving (Show,Eq,Generic)+data OpEval+ = OpEval+ { batchSize :: !(Maybe Int)+ , gremlin :: !Text+ , bindings :: !(Maybe Object)+ , language :: !(Maybe Text)+ , aliases :: !(Maybe (HashMap Text Text))+ , scriptEvaluationTimeout :: !(Maybe Int)+ }+ deriving (Eq, Generic, Show) instance ToJSON OpEval where toJSON = GAeson.genericToJSON GAeson.opt
src/Network/Greskell/WebSocket/Response.hs view
@@ -1,70 +1,62 @@-{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-} -- | -- Module: Network.Greskell.WebSocket.Response -- Description: Response from Gremlin Server -- Maintainer: Toshio Ito <debug.ito@gmail.com> ----- +-- module Network.Greskell.WebSocket.Response- ( -- * ResponseMessage- ResponseMessage(..),- -- * ResponseStatus- ResponseStatus(..),- -- * ResponseResult- ResponseResult(..),- -- * ResponseCode- ResponseCode(..),- codeToInt,- codeFromInt,- isTerminating,- isSuccess,- isClientSideError,- isServerSideError- ) where+ ( -- * ResponseMessage+ ResponseMessage (..)+ -- * ResponseStatus+ , ResponseStatus (..)+ -- * ResponseResult+ , ResponseResult (..)+ -- * ResponseCode+ , ResponseCode (..)+ , codeToInt+ , codeFromInt+ , isTerminating+ , isSuccess+ , isClientSideError+ , isServerSideError+ ) where -import Control.Applicative ((<$>), (<*>))-import Data.Aeson- ( Object, ToJSON(..), FromJSON(..), Value(Number, Object),- defaultOptions, genericParseJSON- )-import Data.Greskell.GraphSON- ( gsonValue, FromGraphSON(..), parseUnwrapAll, (.:),- GValueBody(..)- )-import Data.Greskell.GraphSON.GValue (gValueBody)-import Data.Text (Text)-import Data.UUID (UUID)-import GHC.Generics (Generic)+import Control.Applicative ((<$>), (<*>))+import Data.Aeson (FromJSON (..), Object, ToJSON (..),+ Value (Number, Object), defaultOptions,+ genericParseJSON)+import Data.Greskell.GraphSON (FromGraphSON (..), GValueBody (..), gsonValue,+ parseUnwrapAll, (.:))+import Data.Greskell.GraphSON.GValue (gValueBody)+import Data.Text (Text)+import Data.UUID (UUID)+import GHC.Generics (Generic) -- | Response status code-data ResponseCode =- Success- | NoContent- | PartialContent- | Unauthorized- | Authenticate- | MalformedRequest- | InvalidRequestArguments- | ServerError- | ScriptEvaluationError- | ServerTimeout- | ServerSerializationError- deriving (Show,Eq,Ord,Enum,Bounded)+data ResponseCode = Success | NoContent | PartialContent | Unauthorized | Authenticate | MalformedRequest | InvalidRequestArguments | ServerError | ScriptEvaluationError | ServerTimeout | ServerSerializationError deriving+ ( Bounded+ , Enum+ , Eq+ , Ord+ , Show+ ) codeToInt :: ResponseCode -> Int codeToInt c = case c of- Success -> 200- NoContent -> 204- PartialContent -> 206- Unauthorized -> 401- Authenticate -> 407- MalformedRequest -> 498- InvalidRequestArguments -> 499- ServerError -> 500- ScriptEvaluationError -> 597- ServerTimeout -> 598+ Success -> 200+ NoContent -> 204+ PartialContent -> 206+ Unauthorized -> 401+ Authenticate -> 407+ MalformedRequest -> 498+ InvalidRequestArguments -> 499+ ServerError -> 500+ ScriptEvaluationError -> 597+ ServerTimeout -> 598 ServerSerializationError -> 599 codeFromInt :: Int -> Maybe ResponseCode@@ -80,46 +72,25 @@ 597 -> Just ScriptEvaluationError 598 -> Just ServerTimeout 599 -> Just ServerSerializationError- _ -> Nothing+ _ -> Nothing -- | Returns 'True' if the 'ResponseCode' is a terminating code. isTerminating :: ResponseCode -> Bool isTerminating PartialContent = False-isTerminating _ = True+isTerminating _ = True isCodeClass :: Int -> ResponseCode -> Bool isCodeClass n c = (codeToInt c `div` 100) == n -- | Returns 'True' if the 'ResponseCode' is a success.------ >>> isSuccess Success--- True--- >>> isSuccess Unauthorized--- False--- >>> isSuccess ServerError--- False isSuccess :: ResponseCode -> Bool isSuccess = isCodeClass 2 -- | Returns 'True' if the 'ResponseCode' is a client-side failure.------ >>> isClientSideError Success--- False--- >>> isClientSideError Unauthorized--- True--- >>> isClientSideError ServerError--- False isClientSideError :: ResponseCode -> Bool isClientSideError = isCodeClass 4 -- | Returns 'True' if the 'ResponseCode' is a server-side failure.------ >>> isServerSideError Success--- False--- >>> isServerSideError Unauthorized--- False--- >>> isServerSideError ServerError--- True isServerSideError :: ResponseCode -> Bool isServerSideError = isCodeClass 5 @@ -136,13 +107,13 @@ toJSON = toJSON . codeToInt -- | \"status\" field.-data ResponseStatus =- ResponseStatus- { code :: !ResponseCode,- message :: !Text,- attributes :: !Object- }- deriving (Show,Eq,Generic)+data ResponseStatus+ = ResponseStatus+ { code :: !ResponseCode+ , message :: !Text+ , attributes :: !Object+ }+ deriving (Eq, Generic, Show) instance FromJSON ResponseStatus where parseJSON v = parseGraphSON =<< parseJSON v@@ -155,23 +126,23 @@ <*> o .: "message" <*> o .: "attributes" gb -> fail ("Expected GObject, but got " ++ show gb)- + -- | \"result\" field.-data ResponseResult s =- ResponseResult- { resultData :: !s,- -- ^ \"data\" field.- meta :: !Object- }- deriving (Show,Eq,Generic)+data ResponseResult s+ = ResponseResult+ { resultData :: !s+ -- ^ \"data\" field.+ , meta :: !Object+ }+ deriving (Eq, Generic, Show) instance FromGraphSON s => FromJSON (ResponseResult s) where parseJSON v = parseGraphSON =<< parseJSON v instance FromGraphSON s => FromGraphSON (ResponseResult s) where parseGraphSON gv = case gValueBody gv of- GObject o -> + GObject o -> ResponseResult <$> o .: "data" <*> o .: "meta"@@ -184,20 +155,20 @@ -- <http://tinkerpop.apache.org/docs/current/dev/provider/>. -- -- Type @s@ is the type of the response data.-data ResponseMessage s =- ResponseMessage- { requestId :: !UUID,- status :: !ResponseStatus,- result :: !(ResponseResult s)- }- deriving (Show,Eq,Generic)+data ResponseMessage s+ = ResponseMessage+ { requestId :: !UUID+ , status :: !ResponseStatus+ , result :: !(ResponseResult s)+ }+ deriving (Eq, Generic, Show) instance FromGraphSON s => FromJSON (ResponseMessage s) where parseJSON v = parseGraphSON =<< parseJSON v instance FromGraphSON s => FromGraphSON (ResponseMessage s) where parseGraphSON gv = case gValueBody gv of- GObject o -> + GObject o -> ResponseMessage <$> (o .: "requestId") <*> (o .: "status")
src/Network/Greskell/WebSocket/Util.hs view
@@ -5,11 +5,11 @@ -- -- __Internal module__. module Network.Greskell.WebSocket.Util- ( slurp,- drain- ) where+ ( slurp+ , drain+ ) where -import Data.Monoid ((<>))+import Data.Monoid ((<>)) import qualified Data.Vector as V slurp :: Monad m => m (Maybe a) -> m (V.Vector a)@@ -18,7 +18,7 @@ go got = do mres <- act case mres of- Nothing -> return got+ Nothing -> return got Just res -> go $! (V.snoc got res) drain :: Monad m => m (Maybe a) -> m ()@@ -28,4 +28,4 @@ mres <- act case mres of Nothing -> return ()- Just _ -> go+ Just _ -> go
test/Network/Greskell/WebSocket/Codec/JSONSpec.hs view
@@ -1,36 +1,39 @@-{-# LANGUAGE OverloadedStrings, DuplicateRecordFields, NoMonomorphismRestriction #-}-module Network.Greskell.WebSocket.Codec.JSONSpec (main,spec) where+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.Greskell.WebSocket.Codec.JSONSpec+ ( main+ , spec+ ) where -import Control.Applicative ((<$>))-import Control.Monad (forM_)-import Data.Aeson (Value(Null, Number), (.=))-import qualified Data.Aeson as A-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL-import Data.Greskell.GraphSON- ( GValue, GValueBody(..),- nonTypedGValue, typedGValue'- )-import Data.Greskell.Greskell (unsafeGreskell, Greskell)-import qualified Data.HashMap.Strict as HM-import Data.Maybe (fromJust)-import Data.Monoid (mempty, (<>))-import qualified Data.UUID as UUID-import qualified Data.Vector as V-import Test.Hspec+import Control.Applicative ((<$>))+import Control.Monad (forM_)+import Data.Aeson (Value (Null, Number), (.=))+import qualified Data.Aeson as A+import qualified Data.Aeson.KeyMap as KM+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import Data.Greskell.GraphSON (GValue, GValueBody (..),+ nonTypedGValue, typedGValue')+import Data.Greskell.Greskell (Greskell, unsafeGreskell)+import qualified Data.HashMap.Strict as HM+import Data.Maybe (fromJust)+import Data.Monoid (mempty, (<>))+import qualified Data.UUID as UUID+import qualified Data.Vector as V+import Test.Hspec -import Network.Greskell.WebSocket.Request- ( RequestMessage(..), toRequestMessage- )-import Network.Greskell.WebSocket.Request.Common (SASLMechanism(..), Operation, Base64(..))-import Network.Greskell.WebSocket.Request.Standard- ( OpAuthentication(..), OpEval(..)- )-import qualified Network.Greskell.WebSocket.Request.Session as S-import Network.Greskell.WebSocket.Response- (ResponseMessage(..), ResponseStatus(..), ResponseResult(..), ResponseCode(..))-import Network.Greskell.WebSocket.Codec (Codec(..))-import Network.Greskell.WebSocket.Codec.JSON (jsonCodec)+import Network.Greskell.WebSocket.Codec (Codec (..))+import Network.Greskell.WebSocket.Codec.JSON (jsonCodec)+import Network.Greskell.WebSocket.Request (RequestMessage (..), toRequestMessage)+import Network.Greskell.WebSocket.Request.Common (Base64 (..), Operation,+ SASLMechanism (..))+import qualified Network.Greskell.WebSocket.Request.Session as S+import Network.Greskell.WebSocket.Request.Standard (OpAuthentication (..), OpEval (..))+import Network.Greskell.WebSocket.Response (ResponseCode (..),+ ResponseMessage (..),+ ResponseResult (..),+ ResponseStatus (..)) main :: IO () main = hspec spec@@ -47,7 +50,7 @@ loadSampleValue filename = do json_text <- loadSample filename case A.eitherDecode' json_text of- Left e -> error e+ Left e -> error e Right v -> return v uuidFromString :: String -> UUID.UUID@@ -88,13 +91,13 @@ meta = mempty } exp_v1 = nonTypedGValue $ GArray $ V.fromList- [ nonTypedGValue $ GObject $ HM.fromList+ [ nonTypedGValue $ GObject $ KM.fromList [ ("id", nonTypedGValue $ GNumber 1), ("label", nonTypedGValue $ GString "person"), ("type", nonTypedGValue $ GString "vertex")- ] + ] ]- exp_typed_vertex = typedGValue' "g:Vertex" $ GObject $ HM.fromList+ exp_typed_vertex = typedGValue' "g:Vertex" $ GObject $ KM.fromList [ ("id", typedGValue' "g:Int32" $ GNumber 1), ("label", nonTypedGValue $ GString "person") ]@@ -113,7 +116,7 @@ encodedValue :: Codec s -> RequestMessage -> Value encodedValue c req = case A.eitherDecode $ encodeWith c req of- Left e -> error e+ Left e -> error e Right v -> v encodeCase :: String -> RequestMessage -> Spec@@ -136,7 +139,7 @@ $ OpEval { batchSize = Nothing, gremlin = "g.V(x)",- bindings = Just $ HM.fromList [("x", Number 1)],+ bindings = Just $ KM.fromList [("x", Number 1)], language = Just "gremlin-groovy", aliases = Nothing, scriptEvaluationTimeout = Nothing@@ -145,7 +148,7 @@ $ OpEval { batchSize = Nothing, gremlin = "social.V(x)",- bindings = Just $ HM.fromList [("x", Number 1)],+ bindings = Just $ KM.fromList [("x", Number 1)], language = Just "gremlin-groovy", aliases = Just $ HM.fromList [("g", "social")], scriptEvaluationTimeout = Nothing@@ -154,7 +157,7 @@ $ S.OpEval { S.batchSize = Nothing, S.gremlin = "g.V(x)",- S.bindings = Just $ HM.fromList [("x", Number 1)],+ S.bindings = Just $ KM.fromList [("x", Number 1)], S.language = Just "gremlin-groovy", S.aliases = Nothing, S.scriptEvaluationTimeout = Nothing,@@ -165,7 +168,7 @@ $ S.OpEval { S.batchSize = Nothing, S.gremlin = "social.V(x)",- S.bindings = Just $ HM.fromList [("x", Number 1)],+ S.bindings = Just $ KM.fromList [("x", Number 1)], S.language = Just "gremlin-groovy", S.aliases = Just $ HM.fromList [("g", "social")], S.scriptEvaluationTimeout = Nothing,
+ test/Network/Greskell/WebSocket/ResponseSpec.hs view
@@ -0,0 +1,25 @@+module Network.Greskell.WebSocket.ResponseSpec+ ( main+ , spec+ ) where++import Control.Monad (mapM_)+import Test.Hspec++import Network.Greskell.WebSocket.Response (ResponseCode (..), isClientSideError,+ isServerSideError, isSuccess)++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "isSuccess" $ do+ mapM_ (uncurry $ makeResponseCodeSpec isSuccess) $ [(Success, True), (Unauthorized, False), (ServerError, False)]+ describe "isClientSideError" $ do+ mapM_ (uncurry $ makeResponseCodeSpec isClientSideError) $ [(Success, False), (Unauthorized, True), (ServerError, False)]+ describe "isServerSideError" $ do+ mapM_ (uncurry $ makeResponseCodeSpec isServerSideError) $ [(Success, False), (Unauthorized, False), (ServerError, True)]++makeResponseCodeSpec :: (ResponseCode -> Bool) -> ResponseCode -> Bool -> Spec+makeResponseCodeSpec testee input want = specify (show input) $ testee input `shouldBe` want
test/ServerTest.hs view
@@ -1,9 +1,13 @@-{-# LANGUAGE OverloadedStrings, DuplicateRecordFields #-}-module Main (main,spec) where-import Test.Hspec+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+module Main+ ( main+ , spec+ ) where+import Test.Hspec +import qualified ServerTest.Client as Client import qualified ServerTest.Connection as Conn-import qualified ServerTest.Client as Client main :: IO () main = hspec spec
test/ServerTest/Client.hs view
@@ -1,39 +1,38 @@ {-# LANGUAGE OverloadedStrings #-}-module ServerTest.Client (main,spec) where+module ServerTest.Client+ ( main+ , spec+ ) where -import Control.Concurrent (threadDelay)-import Control.Concurrent.Async (withAsync, mapConcurrently)-import Control.Exception.Safe (bracket)-import Control.Monad (forM_)-import Data.Aeson (Value(Number))-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HM-import Data.Maybe (isNothing, isJust, fromJust)-import Data.Text (Text)-import qualified Data.Vector as V-import qualified Network.WebSockets as WS-import Test.Hspec+import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (mapConcurrently, withAsync)+import Control.Exception.Safe (bracket)+import Control.Monad (forM_)+import Data.Aeson (Value (Number))+import qualified Data.Aeson.KeyMap as KM+import Data.HashMap.Strict (HashMap)+import Data.Maybe (fromJust, isJust, isNothing)+import Data.Text (Text)+import qualified Data.Vector as V+import qualified Network.WebSockets as WS+import Test.Hspec -import Data.Greskell.Greskell (Greskell)-import qualified Data.Greskell.Greskell as G-import Data.Greskell.GMap (GMap, GMapEntry, unGMapEntry)+import Data.Greskell.GMap (GMap, GMapEntry, unGMapEntry)+import Data.Greskell.Greskell (Greskell)+import qualified Data.Greskell.Greskell as G -import Network.Greskell.WebSocket.Client- ( Host, Port, Client, Options,- connectWith, close, submit,- defOptions, batchSize, connectionSettings, responseTimeout,- nextResult, slurpResults,- SubmitException(ResponseError, ParseError)- )-import Network.Greskell.WebSocket.Connection- (RequestException(ResponseTimeout))-import Network.Greskell.WebSocket.Request (RequestMessage(requestId))-import qualified Network.Greskell.WebSocket.Response as Res+import Network.Greskell.WebSocket.Client (Client, Host, Options, Port,+ SubmitException (ParseError, ResponseError),+ batchSize, close, connectWith,+ connectionSettings, defOptions, nextResult,+ responseTimeout, slurpResults, submit)+import Network.Greskell.WebSocket.Connection (RequestException (ResponseTimeout))+import Network.Greskell.WebSocket.Request (RequestMessage (requestId))+import qualified Network.Greskell.WebSocket.Response as Res -import TestUtil.Env (withEnvForExtServer, withEnvForIntServer)-import TestUtil.MockServer- ( wsServer, receiveRequest, simpleRawResponse, waitForServer- )+import TestUtil.Env (withEnvForExtServer, withEnvForIntServer)+import TestUtil.MockServer (receiveRequest, simpleRawResponse,+ waitForServer, wsServer) main :: IO () main = hspec spec@@ -71,7 +70,7 @@ specify "eval [Int]" $ withClient $ \client -> do let g = G.list $ map fromInteger [1..20] :: Greskell [Int] rh <- submit client g Nothing- forM_ [1..20] $ \n -> + forM_ [1..20] $ \n -> nextResult rh `shouldReturn` Just n nextResult rh `shouldReturn` Nothing nextResult rh `shouldReturn` Nothing@@ -89,7 +88,7 @@ specify "eval (bound Double)" $ withClient $ \client -> do let gx = G.unsafeGreskell "x" g = 92.125 + gx :: Greskell Double- b = HM.fromList [("x", Number 22.25)]+ b = KM.fromList [("x", Number 22.25)] rh <- submit client g (Just b) slurpResults rh `shouldReturn` V.fromList [114.375] specify "multiple response messages" $ \(host, port) -> do@@ -103,7 +102,7 @@ let g :: Greskell Int g = G.unsafeGreskell "\"some string\"" expEx (ParseError _ _) = True- expEx _ = False+ expEx _ = False rh <- submit client g Nothing nextResult rh `shouldThrow` expEx nextResult rh `shouldThrow` expEx@@ -122,12 +121,12 @@ let g :: Greskell Int g = G.unsafeGreskell "throw new Exception(\"BOOM\")" expEx (ResponseError res) = (Res.code $ Res.status res) == Res.ScriptEvaluationError- expEx _ = False+ expEx _ = False rh <- submit client g Nothing nextResult rh `shouldThrow` expEx nextResult rh `shouldThrow` expEx- + bad_server_spec :: SpecWith Port bad_server_spec = do specify "error ResponseMessage" $ \port -> do@@ -135,7 +134,7 @@ req <- receiveRequest wsconn WS.sendBinaryData wsconn $ simpleRawResponse (requestId req) 500 "null" expEx (ResponseError res) = (Res.code $ Res.status res) == Res.ServerError- expEx _ = False+ expEx _ = False withAsync server $ \_ -> do waitForServer forClient "localhost" port $ \client -> do@@ -155,7 +154,7 @@ { responseTimeout = 1 } expEx ResponseTimeout = True- expEx _ = False+ expEx _ = False withAsync server $ \_ -> do waitForServer forClient' opt "localhost" port $ \client -> do@@ -164,4 +163,4 @@ nextResult rh `shouldReturn` Just 99 nextResult rh `shouldThrow` expEx nextResult rh `shouldThrow` expEx- +
test/ServerTest/Connection.hs view
@@ -1,53 +1,61 @@-{-# LANGUAGE OverloadedStrings, DuplicateRecordFields #-}-module ServerTest.Connection (main,spec) where+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+module ServerTest.Connection+ ( main+ , spec+ ) where -import Control.Exception.Safe (bracket, Exception, withException, SomeException, throwString)-import Control.Concurrent (threadDelay)-import Control.Concurrent.Async (mapConcurrently, Async, withAsync, async, wait)-import Control.Concurrent.STM- ( newEmptyTMVarIO, putTMVar, takeTMVar, atomically,- TVar, newTVarIO, modifyTVar, readTVar,- TQueue, newTQueueIO, writeTQueue, flushTQueue- )-import Control.Monad (when, forever, forM_, mapM)-import Data.Aeson (Value(Number), FromJSON(..), ToJSON(toJSON), Object)-import qualified Data.Aeson as Aeson-import qualified Data.Aeson.Types as Aeson (parseEither)-import qualified Data.ByteString.Lazy as BSL-import Data.Maybe (isNothing, isJust, fromJust)-import Data.Monoid ((<>))-import qualified Data.HashMap.Strict as HM-import Data.Greskell.GraphSON (GraphSON, gsonValue)-import Data.Text (Text, pack)-import qualified Data.Vector as V-import Data.UUID (UUID)-import qualified Data.UUID as UUID-import Data.UUID.V4 (nextRandom)-import qualified Network.WebSockets as WS-import System.IO (stderr, hPutStrLn)-import Test.Hspec+import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (Async, async, mapConcurrently, wait,+ withAsync)+import Control.Concurrent.STM (TQueue, TVar, atomically, flushTQueue,+ modifyTVar, newEmptyTMVarIO,+ newTQueueIO, newTVarIO, putTMVar,+ readTVar, takeTMVar, writeTQueue)+import Control.Exception.Safe (Exception, SomeException, bracket,+ throwString, withException)+import Control.Monad (forM_, forever, mapM, when)+import Data.Aeson (FromJSON (..), Object,+ ToJSON (toJSON), Value (Number))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.KeyMap as KM+import qualified Data.Aeson.Types as Aeson (parseEither)+import qualified Data.ByteString.Lazy as BSL+import Data.Greskell.GraphSON (GraphSON, gsonValue)+import Data.Maybe (fromJust, isJust, isNothing)+import Data.Monoid ((<>))+import Data.Text (Text, pack)+import Data.UUID (UUID)+import qualified Data.UUID as UUID+import Data.UUID.V4 (nextRandom)+import qualified Data.Vector as V+import GHC.Records (HasField (..))+import qualified Network.WebSockets as WS+import System.IO (hPutStrLn, stderr)+import Test.Hspec -import Network.Greskell.WebSocket.Connection- ( Host, Port, Connection, ResponseHandle,- close, connect, sendRequest', sendRequest, slurpResponses,- nextResponse,- RequestException(..), GeneralException(..),- Settings(onGeneralException, responseTimeout, concurrency, requestQueueSize),- defJSONSettings- )-import Network.Greskell.WebSocket.Request- ( RequestMessage(requestId), toRequestMessage, makeRequestMessage- )-import Network.Greskell.WebSocket.Request.Standard (OpEval(..))-import Network.Greskell.WebSocket.Response- ( ResponseMessage(requestId, status, result), ResponseStatus(code), ResponseCode(..),- ResponseResult(resultData)- )-import qualified Network.Greskell.WebSocket.Response as Response+import Network.Greskell.WebSocket.Connection (Connection, GeneralException (..),+ Host, Port, RequestException (..),+ ResponseHandle,+ Settings (concurrency, onGeneralException, requestQueueSize, responseTimeout),+ close, connect, defJSONSettings,+ nextResponse, sendRequest,+ sendRequest', slurpResponses)+import Network.Greskell.WebSocket.Request (RequestMessage (requestId),+ makeRequestMessage, toRequestMessage)+import Network.Greskell.WebSocket.Request.Standard (OpEval (..))+import Network.Greskell.WebSocket.Response (ResponseCode (..),+ ResponseMessage (requestId, result, status),+ ResponseResult (resultData),+ ResponseStatus (code)) -import qualified TestUtil.TCounter as TCounter-import TestUtil.Env (withEnvForExtServer, withEnvForIntServer)-import TestUtil.MockServer (wsServer, receiveRequest, simpleRawResponse, waitForServer)+import TestUtil.Env (withEnvForExtServer,+ withEnvForIntServer)+import TestUtil.MockServer (receiveRequest, simpleRawResponse,+ waitForServer, wsServer)+import qualified TestUtil.TCounter as TCounter main :: IO ()@@ -124,9 +132,9 @@ expectSomeEx :: SomeException -> Bool expectSomeEx _ = True inspectException act `shouldThrow` expectSomeEx- - ++ conn_basic_spec :: SpecWith (Host, Port) conn_basic_spec = do specify "basic transaction" $ withConn $ \conn -> do@@ -136,18 +144,18 @@ exp_val = [123] res <- sendRequest' conn $ toRequestMessage rid op got <- slurpParseEval res- map (Response.requestId) got `shouldBe` [rid]+ map (getField @"requestId") got `shouldBe` [rid] map (code . status) got `shouldBe` [Success] map responseValues got `shouldBe` [Right exp_val] specify "continuous response with bindings" $ withConn $ \conn -> do rid <- nextRandom let op = (opEval "x") { batchSize = Just 2,- bindings = Just $ HM.fromList [("x", toJSON ([1 .. 10] :: [Int]))]+ bindings = Just $ KM.fromList [("x", toJSON ([1 .. 10] :: [Int]))] } exp_vals :: [Either String [Int]] exp_vals = map Right [[1,2], [3,4], [5,6], [7,8], [9,10]] got <- slurpParseEval =<< (sendRequest' conn $ toRequestMessage rid op)- map (Response.requestId) got `shouldBe` replicate 5 rid+ map (getField @"requestId") got `shouldBe` replicate 5 rid map (code . status) got `shouldBe` ((replicate 4 PartialContent) ++ [Success]) map responseValues got `shouldBe` exp_vals specify "concurrent requests" $ withConn $ \conn -> do@@ -207,8 +215,8 @@ conn_error_spec = do specify "duplicate requests" $ withConn $ \conn -> do req <- makeRequestMessage $ opSleep 300- let expEx (DuplicateRequestId got_rid) = got_rid == requestId (req :: RequestMessage)- expEx _ = False+ let expEx (DuplicateRequestId got_rid) = got_rid == getField @"requestId" req+ expEx _ = False ok_rh <- sendRequest' conn req ng_rh <- sendRequest' conn req ok_res <- slurpEvalValues ok_rh :: IO [Either String [Int]]@@ -217,7 +225,7 @@ specify "request timeout" $ \(host, port) -> do let settings = ourSettings { responseTimeout = 1 } expEx ResponseTimeout = True- expEx _ = False+ expEx _ = False forConn' settings host port $ \conn -> do rh <- sendRequest conn $ opSleep 2000 (nextResponse rh) `shouldThrow` expEx@@ -246,14 +254,14 @@ got `shouldBe` map (\v -> [Right [v]]) [200, 400, 600] it "should make nextResponse throw AlreadyClosed exception. nextResponse should throw it every time it's called" $ withConn $ \conn -> do let expEx AlreadyClosed = True- expEx _ = False+ expEx _ = False close conn rh <- sendRequest conn $ opEval "999" nextResponse rh `shouldThrow` expEx- nextResponse rh `shouldThrow` expEx nextResponse rh `shouldThrow` expEx- + nextResponse rh `shouldThrow` expEx + succUUID :: UUID -> UUID succUUID orig = UUID.fromWords a b c d' where@@ -270,7 +278,7 @@ ++ " It's because of WS.runServer internals." ) exp_ex ServerClosed = True- exp_ex _ = False+ exp_ex _ = False withAsync server $ \_ -> do waitForServer forConn "localhost" port $ \conn -> do@@ -286,7 +294,7 @@ ++ show wscode ) exp_ex ServerClosed = True- exp_ex _ = False+ exp_ex _ = False withAsync server $ \_ -> do waitForServer forConn "localhost" port $ \conn -> do@@ -295,7 +303,7 @@ it "should be ok if the server actively closes the connection" $ \port -> do let server = wsServer port $ \wsconn -> do req <- receiveRequest wsconn- WS.sendBinaryData wsconn $ simpleRawResponse (requestId (req :: RequestMessage)) 200 "[99]"+ WS.sendBinaryData wsconn $ simpleRawResponse (getField @"requestId" req) 200 "[99]" withAsync server $ \_ -> do waitForServer forConn "localhost" port $ \conn -> do@@ -307,7 +315,7 @@ threadDelay 10000 WS.sendClose wsconn ("" :: Text) expEx AlreadyClosed = True- expEx _ = False+ expEx _ = False withAsync server $ \_ -> do waitForServer forConn "localhost" port $ \conn -> do@@ -319,7 +327,7 @@ report_gex <- newEmptyTMVarIO let server = wsServer port $ \wsconn -> do req <- receiveRequest wsconn- let res_id = succUUID $ requestId (req :: RequestMessage) -- deliberately send wrong requestId.+ let res_id = succUUID $ getField @"requestId" req -- deliberately send wrong requestId. res = simpleRawResponse res_id 200 "[333]" WS.sendBinaryData wsconn res reportEx ex = atomically $ putTMVar report_gex ex@@ -328,7 +336,7 @@ waitForServer forConn' settings "localhost" port $ \conn -> do req <- makeRequestMessage $ opEval "333"- let exp_res_id = succUUID $ requestId (req :: RequestMessage)+ let exp_res_id = succUUID $ getField @"requestId" req _ <- sendRequest' conn req got <- atomically $ takeTMVar report_gex got `shouldBe` UnexpectedRequestId exp_res_id@@ -342,14 +350,14 @@ waitForServer forConn' settings "localhost" port $ \conn -> do let expEx (ResponseParseFailure _) = True- expEx _ = False+ expEx _ = False _ <- sendRequest conn $ opEval "100" got <- atomically $ takeTMVar report_gex got `shouldSatisfy` expEx it "should throw ResponseTimeout exception when the server endlessly sends responses" $ \port -> do let server = wsServer port $ \wsconn -> do req <- receiveRequest wsconn- let res_id = requestId (req :: RequestMessage)+ let res_id = getField @"requestId" req sendContinuousRes wsconn res_id 20 sendContinuousRes :: WS.Connection -> UUID -> Int -> IO () sendContinuousRes wsconn res_id n = do@@ -361,7 +369,7 @@ else sendContinuousRes wsconn res_id (n - 1) settings = ourSettings { responseTimeout = 1 } expEx ResponseTimeout = True- expEx _ = False+ expEx _ = False withAsync server $ \_ -> do waitForServer forConn' settings "localhost" port $ \conn -> do@@ -370,4 +378,4 @@ mgot <- (fmap . fmap) (responseValues . fmap parseValue) $ nextResponse rh :: IO (Maybe (Either String [Int])) mgot `shouldBe` (Just $ Right [1]) slurpResponses rh `shouldThrow` expEx- +
test/TestUtil/Env.hs view
@@ -1,13 +1,13 @@ module TestUtil.Env- ( requireEnv,- withEnvForExtServer,- withEnvForIntServer- ) where+ ( requireEnv+ , withEnvForExtServer+ , withEnvForIntServer+ ) where -import System.Environment (lookupEnv)-import Test.Hspec+import System.Environment (lookupEnv)+import Test.Hspec -import Network.Greskell.WebSocket.Connection (Host, Port)+import Network.Greskell.WebSocket.Connection (Host, Port) requireEnv :: String -> IO String requireEnv env_key = maybe bail return =<< lookupEnv env_key
test/TestUtil/MockServer.hs view
@@ -1,24 +1,24 @@ {-# LANGUAGE OverloadedStrings #-} module TestUtil.MockServer- ( wsServer,- parseRequest,- receiveRequest,- simpleRawResponse,- waitForServer- ) where+ ( wsServer+ , parseRequest+ , receiveRequest+ , simpleRawResponse+ , waitForServer+ ) where -import Control.Concurrent (threadDelay)-import Control.Exception.Safe (throwString)-import qualified Data.Aeson as Aeson-import qualified Data.ByteString.Lazy as BSL-import Data.Monoid ((<>))-import Data.Text (Text, pack)-import Data.UUID (UUID)-import qualified Data.UUID as UUID-import qualified Network.WebSockets as WS+import Control.Concurrent (threadDelay)+import Control.Exception.Safe (throwString)+import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy as BSL+import Data.Monoid ((<>))+import Data.Text (Text, pack)+import Data.UUID (UUID)+import qualified Data.UUID as UUID+import qualified Network.WebSockets as WS -import Network.Greskell.WebSocket.Codec (decodeBinary)-import Network.Greskell.WebSocket.Request (RequestMessage)+import Network.Greskell.WebSocket.Codec (decodeBinary)+import Network.Greskell.WebSocket.Request (RequestMessage) wsServer :: Int -- ^ port number@@ -36,7 +36,7 @@ receiveRequest wsconn = do raw_msg <- WS.receiveData wsconn case parseRequest raw_msg of- Left e -> throwString e+ Left e -> throwString e Right r -> return r simpleRawResponse :: UUID -> Int -> Text -> Text
test/TestUtil/TCounter.hs view
@@ -1,30 +1,30 @@ -- | -- Module: TestUtil.TCounter--- Description: +-- Description: -- Maintainer: Toshio Ito <debug.ito@gmail.com> ----- +-- module TestUtil.TCounter- ( TCounter,- new,- modify,- now,- waitFor,- history,- count- ) where+ ( TCounter+ , new+ , modify+ , now+ , waitFor+ , history+ , count+ ) where -import Control.Applicative ((<$>), (<*>))-import Control.Concurrent.STM- ( TVar, newTVarIO, modifyTVar, readTVar,- STM, atomically, retry- )+import Control.Applicative ((<$>), (<*>))+import Control.Concurrent.STM (STM, TVar, atomically, modifyTVar, newTVarIO, readTVar,+ retry) -- | Transaction counter.-data TCounter = TCounter { tcCurrent :: TVar Int,- tcHistory :: TVar [Int]- }- +data TCounter+ = TCounter+ { tcCurrent :: TVar Int+ , tcHistory :: TVar [Int]+ }+ new :: IO TCounter new = TCounter <$> newTVarIO 0 <*> newTVarIO []