diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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` diff --git a/greskell-websocket.cabal b/greskell-websocket.cabal --- a/greskell-websocket.cabal +++ b/greskell-websocket.cabal @@ -1,5 +1,5 @@ name: greskell-websocket -version: 0.1.2.6 +version: 1.0.0.6 author: Toshio Ito maintainer: Toshio Ito 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 diff --git a/src/Network/Greskell/WebSocket.hs b/src/Network/Greskell/WebSocket.hs --- a/src/Network/Greskell/WebSocket.hs +++ b/src/Network/Greskell/WebSocket.hs @@ -2,13 +2,13 @@ -- Module: Network.Greskell.WebSocket -- Description: Client of Gremlin Server using WebSocket -- Maintainer: Toshio Ito --- +-- 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 -- diff --git a/src/Network/Greskell/WebSocket/Client.hs b/src/Network/Greskell/WebSocket/Client.hs --- a/src/Network/Greskell/WebSocket/Client.hs +++ b/src/Network/Greskell/WebSocket/Client.hs @@ -3,30 +3,30 @@ -- Description: High-level interface to Gremlin Server -- Maintainer: Toshio Ito -- --- +-- 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) diff --git a/src/Network/Greskell/WebSocket/Client/Impl.hs b/src/Network/Greskell/WebSocket/Client/Impl.hs --- a/src/Network/Greskell/WebSocket/Client/Impl.hs +++ b/src/Network/Greskell/WebSocket/Client/Impl.hs @@ -1,53 +1,50 @@ -{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module: Network.Greskell.WebSocket.Client.Impl --- Description: +-- Description: -- Maintainer: Toshio Ito -- -- __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 diff --git a/src/Network/Greskell/WebSocket/Client/Options.hs b/src/Network/Greskell/WebSocket/Client/Options.hs --- a/src/Network/Greskell/WebSocket/Client/Options.hs +++ b/src/Network/Greskell/WebSocket/Client/Options.hs @@ -3,49 +3,49 @@ -- Description: Options to create a Client -- Maintainer: Toshio Ito -- --- +-- 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 = diff --git a/src/Network/Greskell/WebSocket/Codec.hs b/src/Network/Greskell/WebSocket/Codec.hs --- a/src/Network/Greskell/WebSocket/Codec.hs +++ b/src/Network/Greskell/WebSocket/Codec.hs @@ -3,36 +3,39 @@ -- Description: Encoder\/decoder of Request\/Response -- Maintainer: Toshio Ito -- --- +-- 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 diff --git a/src/Network/Greskell/WebSocket/Codec/JSON.hs b/src/Network/Greskell/WebSocket/Codec/JSON.hs --- a/src/Network/Greskell/WebSocket/Codec/JSON.hs +++ b/src/Network/Greskell/WebSocket/Codec/JSON.hs @@ -4,18 +4,18 @@ -- Description: application\/json codec -- Maintainer: Toshio Ito -- --- +-- 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. -- diff --git a/src/Network/Greskell/WebSocket/Connection.hs b/src/Network/Greskell/WebSocket/Connection.hs --- a/src/Network/Greskell/WebSocket/Connection.hs +++ b/src/Network/Greskell/WebSocket/Connection.hs @@ -3,29 +3,29 @@ -- Description: WebSocket Connection to Gremlin Server -- Maintainer: Toshio Ito -- --- +-- 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 diff --git a/src/Network/Greskell/WebSocket/Connection/Impl.hs b/src/Network/Greskell/WebSocket/Connection/Impl.hs --- a/src/Network/Greskell/WebSocket/Connection/Impl.hs +++ b/src/Network/Greskell/WebSocket/Connection/Impl.hs @@ -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 diff --git a/src/Network/Greskell/WebSocket/Connection/Settings.hs b/src/Network/Greskell/WebSocket/Connection/Settings.hs --- a/src/Network/Greskell/WebSocket/Connection/Settings.hs +++ b/src/Network/Greskell/WebSocket/Connection/Settings.hs @@ -3,24 +3,28 @@ -- Description: Settings for making Connection -- Maintainer: Toshio Ito -- --- +-- 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 diff --git a/src/Network/Greskell/WebSocket/Connection/Type.hs b/src/Network/Greskell/WebSocket/Connection/Type.hs --- a/src/Network/Greskell/WebSocket/Connection/Type.hs +++ b/src/Network/Greskell/WebSocket/Connection/Type.hs @@ -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 diff --git a/src/Network/Greskell/WebSocket/Request.hs b/src/Network/Greskell/WebSocket/Request.hs --- a/src/Network/Greskell/WebSocket/Request.hs +++ b/src/Network/Greskell/WebSocket/Request.hs @@ -1,39 +1,40 @@ -{-# LANGUAGE DuplicateRecordFields, DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} -- | -- Module: Network.Greskell.WebSocket.Request -- Description: Request to Gremlin Server -- Maintainer: Toshio Ito -- --- +-- 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 -- . -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 diff --git a/src/Network/Greskell/WebSocket/Request/Aeson.hs b/src/Network/Greskell/WebSocket/Request/Aeson.hs --- a/src/Network/Greskell/WebSocket/Request/Aeson.hs +++ b/src/Network/Greskell/WebSocket/Request/Aeson.hs @@ -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" diff --git a/src/Network/Greskell/WebSocket/Request/Common.hs b/src/Network/Greskell/WebSocket/Request/Common.hs --- a/src/Network/Greskell/WebSocket/Request/Common.hs +++ b/src/Network/Greskell/WebSocket/Request/Common.hs @@ -4,19 +4,19 @@ -- Description: Common data types for Request objects -- Maintainer: Toshio Ito -- --- +-- 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 diff --git a/src/Network/Greskell/WebSocket/Request/Session.hs b/src/Network/Greskell/WebSocket/Request/Session.hs --- a/src/Network/Greskell/WebSocket/Request/Session.hs +++ b/src/Network/Greskell/WebSocket/Request/Session.hs @@ -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 -- --- +-- 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 diff --git a/src/Network/Greskell/WebSocket/Request/Standard.hs b/src/Network/Greskell/WebSocket/Request/Standard.hs --- a/src/Network/Greskell/WebSocket/Request/Standard.hs +++ b/src/Network/Greskell/WebSocket/Request/Standard.hs @@ -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 -- --- +-- 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 diff --git a/src/Network/Greskell/WebSocket/Response.hs b/src/Network/Greskell/WebSocket/Response.hs --- a/src/Network/Greskell/WebSocket/Response.hs +++ b/src/Network/Greskell/WebSocket/Response.hs @@ -1,70 +1,62 @@ -{-# LANGUAGE DeriveGeneric, OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} -- | -- Module: Network.Greskell.WebSocket.Response -- Description: Response from Gremlin Server -- Maintainer: Toshio Ito -- --- +-- 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 @@ -- . -- -- 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") diff --git a/src/Network/Greskell/WebSocket/Util.hs b/src/Network/Greskell/WebSocket/Util.hs --- a/src/Network/Greskell/WebSocket/Util.hs +++ b/src/Network/Greskell/WebSocket/Util.hs @@ -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 diff --git a/test/Network/Greskell/WebSocket/Codec/JSONSpec.hs b/test/Network/Greskell/WebSocket/Codec/JSONSpec.hs --- a/test/Network/Greskell/WebSocket/Codec/JSONSpec.hs +++ b/test/Network/Greskell/WebSocket/Codec/JSONSpec.hs @@ -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, diff --git a/test/Network/Greskell/WebSocket/ResponseSpec.hs b/test/Network/Greskell/WebSocket/ResponseSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Greskell/WebSocket/ResponseSpec.hs @@ -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 diff --git a/test/ServerTest.hs b/test/ServerTest.hs --- a/test/ServerTest.hs +++ b/test/ServerTest.hs @@ -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 diff --git a/test/ServerTest/Client.hs b/test/ServerTest/Client.hs --- a/test/ServerTest/Client.hs +++ b/test/ServerTest/Client.hs @@ -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 - + diff --git a/test/ServerTest/Connection.hs b/test/ServerTest/Connection.hs --- a/test/ServerTest/Connection.hs +++ b/test/ServerTest/Connection.hs @@ -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 - + diff --git a/test/TestUtil/Env.hs b/test/TestUtil/Env.hs --- a/test/TestUtil/Env.hs +++ b/test/TestUtil/Env.hs @@ -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 diff --git a/test/TestUtil/MockServer.hs b/test/TestUtil/MockServer.hs --- a/test/TestUtil/MockServer.hs +++ b/test/TestUtil/MockServer.hs @@ -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 diff --git a/test/TestUtil/TCounter.hs b/test/TestUtil/TCounter.hs --- a/test/TestUtil/TCounter.hs +++ b/test/TestUtil/TCounter.hs @@ -1,30 +1,30 @@ -- | -- Module: TestUtil.TCounter --- Description: +-- Description: -- Maintainer: Toshio Ito -- --- +-- 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 []