colchis (empty) → 0.1.0.0
raw patch · 12 files changed
+477/−0 lines, 12 filesdep +aesondep +basedep +bifunctorssetup-changed
Dependencies added: aeson, base, bifunctors, conceit, network, pipes, pipes-aeson, pipes-attoparsec, pipes-bytestring, pipes-network, text, transformers, transformers-compat, void
Files
- CHANGELOG +0/−0
- LICENSE +27/−0
- README.md +9/−0
- Setup.hs +2/−0
- colchis.cabal +49/−0
- src/Network/Colchis.hs +100/−0
- src/Network/Colchis/Protocol.hs +20/−0
- src/Network/Colchis/Protocol/JSONRPC20.hs +66/−0
- src/Network/Colchis/Protocol/JSONRPC20/Request.hs +24/−0
- src/Network/Colchis/Protocol/JSONRPC20/Response.hs +33/−0
- src/Network/Colchis/Transport.hs +17/−0
- src/Network/Colchis/Transport/TCP.hs +130/−0
+ CHANGELOG view
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2014, Daniel Díaz Carrete+All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice, this+ list of conditions and the following disclaimer in the documentation and/or+ other materials provided with the distribution.++* Neither the name of the {organization} nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,9 @@+colchis+=======++A rudimentary yet overengineered client for JSON-RPC 2.0 over raw TCP.++It was written to communicate with jsonrpc4j servers in "streaming" mode.++https://github.com/briandilley/jsonrpc4j+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ colchis.cabal view
@@ -0,0 +1,49 @@+name: colchis+version: 0.1.0.0+license: BSD3+license-file: LICENSE+data-files: +author: Daniel Díaz Carrete+maintainer: diaz_carrete@yahoo.com+category: Network+build-type: Simple+cabal-version: >= 1.10+Synopsis: Rudimentary JSON-RPC 2.0 client over raw TCP. +Description: Rudimentary JSON-RPC 2.0 client over raw TCP.++Extra-Source-Files:+ README.md+ CHANGELOG++Library+ default-language: Haskell2010+ hs-source-dirs: src+ exposed-modules: + Network.Colchis+ Network.Colchis.Protocol+ Network.Colchis.Protocol.JSONRPC20+ Network.Colchis.Protocol.JSONRPC20.Request+ Network.Colchis.Protocol.JSONRPC20.Response+ Network.Colchis.Transport+ Network.Colchis.Transport.TCP+ other-modules: + build-depends: + base >= 4.4 && < 5,+ transformers >= 0.2 && < 0.5,+ transformers-compat == 0.3.*,+ bifunctors >= 4.1 && < 5,+ pipes >= 4.1.2 && < 4.2,+ pipes-bytestring >= 2.1.0 && < 2.2,+ pipes-attoparsec == 0.5.*,+ pipes-aeson >= 0.4 && < 0.5,+ pipes-network >= 0.6 && < 0.7,+ aeson >=0.7 && < 0.9,+ text >= 0.11.2 && < 1.2,+ void >= 0.6 && < 0.7,+ conceit >= 0.1 && < 0.2,+ network++Source-repository head+ type: git+ location: https://github.com/danidiaz/colchis.git+
+ src/Network/Colchis.hs view
@@ -0,0 +1,100 @@+-- |+-- This module defines the client monad and the type signatures for+-- transports and prototocols.+--+-----------------------------------------------------------------------------++{-# LANGUAGE Rank2Types #-}++module Network.Colchis (+ -- * Client + JSONClient (..)+ , JSONClientError (..)+ , call+ -- * Protocol + , Protocol+ -- * Transport+ , Transport+ -- * Running clients+ , runJSONClient+ -- * Utils+ -- $utils+ , umap+ , umapM+ -- * Re-exported+ -- $reexports+ , hoist+ ) where++import Data.Text+import Data.Aeson+import Control.Monad+import Control.Monad.Trans.Except+import Pipes+import Pipes.Core+import Pipes.Lift++import Network.Colchis.Protocol+import Network.Colchis.Transport+++{-|+ (request associated with the error, error message, response that caused the error)+-}+type JSONClientError = (Value,Text,Value)++{-|+ Emits requests consisting in `Value`s paired with some metadata. The metadata is usually the method name.++ Receives `Value` responses.+-}+type JSONClient s m r = Client (s,Value) Value (ExceptT JSONClientError m) r ++call :: (ToJSON a, FromJSON r, Monad m) => s -> a -> JSONClient s m r +call s a = do+ let jreq = toJSON a+ rj <- request (s,jreq)+ case fromJSON rj of+ Error msg -> lift $ throwE (jreq,pack msg,rj) + Success r -> return r +++{- $utils+ These functions can be used to manipulate requests flowing upstream.+-}++{-|+ Apply a function to all requests flowing upstream in a bidirectional pipe. Returns a function that can be composed with `+>>` or `>+>`.+ -}+umap :: Monad m => (b' -> a') -> b' -> Proxy a' x b' x m r+umap f = go+ where+ go b = request (f b) >>= respond >>= go++{-|+Apply a monadic function to all requests flowing upstream in a bidirectional pipe. Returns a function that can be composed with `+>>` or `>+>`.+-}+umapM :: Monad m => (b' -> m a') -> b' -> Proxy a' x b' x m r+umapM f = go+ where+ go b = lift (f b) >>= request >>= respond >>= go++{-|+ The return value lives inside the monad associated to the transport layer. The run function that peels off that layer depends on the transport. See for example `Network.Colchis.Transport.TCP.runTcp` for the `Network.Colchis.Transport.TCP.tcp` transport.+-}+runJSONClient :: (MonadTrans t, MFunctor t, MonadIO m, Monad (t m)) => Transport t m -> Protocol s m e -> JSONClient s m r -> t m (Either e (Either JSONClientError r)) +runJSONClient server adapter client = + runExceptT $ + runExceptT $+ runEffect $+ hoist (lift.lift) . server + +>> + hoist (lift.hoist lift) . adapter + +>> + hoist (hoist (lift.lift)) client++{- $reexports+ + When the function that runs the transport layer requires the underlying monad to be whittled down to `IO`, `hoist` (along with a suitable monad morphism) can come in handy.++-}
+ src/Network/Colchis/Protocol.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE Rank2Types #-}++module Network.Colchis.Protocol (+ Protocol(..) + ) where++import Data.Aeson+import Control.Monad.Trans.Except+import Pipes+++{-|+ A bidirectional `Proxy` waiting for a request, ready to be composed with `+>>` or `>+>`.++ `Protocol`s format incoming requests from downstream before sending them upstream. They also extract the values from returning protocol responses and send them downstream.++ `Protocol`s isolate clients from the specific details of each protocol. +-}+type Protocol s m e = forall r. (s,Value) -> Proxy Value Value (s,Value) Value (ExceptT e m) r+
+ src/Network/Colchis/Protocol/JSONRPC20.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Colchis.Protocol.JSONRPC20 (+ module Network.Colchis.Protocol+ , jsonRPC20 + , JSONRPC20Error (..)+ , IN.ErrorObject (..)+ ) where++import Network.Colchis.Protocol+import qualified Network.Colchis.Protocol.JSONRPC20.Request as OUT+import qualified Network.Colchis.Protocol.JSONRPC20.Response as IN ++import Data.Text+import Data.Aeson+import Data.Aeson.Types+import Control.Monad+import Control.Monad.Trans.Except+import Control.Monad.Trans.State.Strict+import Pipes+import Pipes.Core+import Pipes.Lift+import qualified Pipes.Prelude as P+import Pipes.Aeson++data JSONRPC20Error = + MalformedResponse Text Value+ |ProtocolMismatch Text+ |ResponseIdMismatch Int Int+ |ErrorResponse IN.ErrorObject+ deriving (Show)++-- http://www.jsonrpc.org/specification+jsonRPC20 :: Monad m => Protocol Text m (Text,Value,JSONRPC20Error)+jsonRPC20 = evalStateP 0 `liftM` go + where+ go (method,mkStructured -> j) = do + msgId <- freshId + jresp <- request . toJSON $ OUT.Request protocolVer method j msgId+ let throwE' x = lift . lift . throwE $ (method,j,x)+ case parseEither parseJSON jresp of+ Left str -> throwE' $ MalformedResponse (pack str) jresp+ Right (IN.Response p' rm' em' id') -> do+ if protocolVer /= p' + then throwE' $ ProtocolMismatch p'+ else case em' of + Just err -> throwE' $ ErrorResponse err+ Nothing -> case rm' of+ Nothing -> throwE' $ + MalformedResponse "missing fields" jresp+ Just val -> case parseEither parseJSON id' of + Left str -> throwE' $ + MalformedResponse "strange id" jresp+ Right i -> if msgId /= i+ then throwE' $ ResponseIdMismatch msgId i+ else respond val >>= go + freshId = lift $ withStateT (flip mod 100 . succ) get+ protocolVer = "2.0"+ mkStructured j = case j of+ o@Object {} -> o+ a@Array {} -> a + Null -> emptyArray+ x -> toJSON $ [x]++
+ src/Network/Colchis/Protocol/JSONRPC20/Request.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE DeriveGeneric #-}++module Network.Colchis.Protocol.JSONRPC20.Request + (+ Request(..)+ ) where++import Data.Aeson+import Data.Aeson.Types+import Data.Text+import GHC.Generics++data Request = Request + { _jsonrpc :: Text+ , _method :: Text+ , _params :: Value+ , _id :: Int+ } deriving (Generic)++instance ToJSON Request where+ toJSON = genericToJSON defaultOptions { fieldLabelModifier = Prelude.tail , omitNothingFields = True }+++
+ src/Network/Colchis/Protocol/JSONRPC20/Response.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE DeriveGeneric #-}++module Network.Colchis.Protocol.JSONRPC20.Response + (+ Response(..)+ , ErrorObject(..)+ ) where++import Data.Aeson+import Data.Aeson.Types+import Data.Text+import GHC.Generics++data ErrorObject = ErrorObject+ { _code :: Int+ , _message :: Text+ , _data :: Maybe Value+ } deriving (Generic,Show)++data Response = Response + { _jsonrpc :: Text+ , _result :: Maybe Value+ , _error :: Maybe ErrorObject+ , _id :: Value+ } deriving (Generic,Show)++options = defaultOptions { fieldLabelModifier = Prelude.tail , omitNothingFields = True }++instance FromJSON Response where+ parseJSON = genericParseJSON options++instance FromJSON ErrorObject where+ parseJSON = genericParseJSON options
+ src/Network/Colchis/Transport.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE Rank2Types #-}++module Network.Colchis.Transport (+ Transport(..) + ) where++import Data.Aeson+import Control.Monad.IO.Class+import Control.Monad.Trans.Except+import Pipes.Core++{-|+ A pipes `Server` waiting for a request, ready to be composed with `+>>` or `>+>`.++ `Transport`s send requests over the wire and receive the responses.+-}+type Transport t m = (MonadIO m) => forall r. Value -> Server Value Value (t m) r
+ src/Network/Colchis/Transport/TCP.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE Rank2Types #-}++module Network.Colchis.Transport.TCP (+ module Network.Colchis.Transport+ , tcp+ , runTcp+ , TransportError(..)+ , ParsingError(..)+ ) where++import Data.Aeson+import Data.Aeson.Encode+import Data.IORef+import Data.Typeable+import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Except+import Control.Concurrent.MVar+import Control.Concurrent.Conceit+import Network.Socket (shutdown,ShutdownCmd(ShutdownBoth))+import Pipes+import Pipes.Attoparsec (ParsingError(..))+import Pipes.Core+import Pipes.Lift+import Pipes.Internal (unsafeHoist)+import Pipes.ByteString as PB+import Pipes.Network.TCP+import Pipes.Aeson+import Pipes.Aeson.Unchecked++import Network.Colchis.Transport++type TcpState = ReaderT (MVar (Maybe Value),MVar Value,IORef ConnState) ++data TransportError =+ RequestParsingError ParsingError+ | UnexpectedData + | UnexpectedConnectionClose+ deriving (Typeable,Show)++data ConnState =+ Idle+ | RequestSent+ | Finished+ deriving (Show)++producerFromMVar :: MVar (Maybe a) -> Producer a IO () +producerFromMVar reqMVar = go+ where + go = do+ mj <- liftIO $ takeMVar reqMVar + case mj of + Nothing -> return ()+ Just j -> do+ yield j+ go++consumerFromMVar :: MVar a -> Consumer a IO x +consumerFromMVar respMVar = forever $ await >>= liftIO . putMVar respMVar ++tcp :: Transport TcpState m+tcp = go+ where+ go req = do+ (reqMVar,respMVar,connState) <- lift ask+ liftIO $ atomicWriteIORef connState RequestSent + liftIO $ putMVar reqMVar (Just req)+ resp <- liftIO (takeMVar respMVar) + liftIO $ atomicWriteIORef connState Idle+ respond resp >>= go +++runTcp :: HostName -> ServiceName -> TcpState IO r -> IO (Either TransportError r) +runTcp host port transport = + withSocketsDo $ connect host port $ \(sock,sockaddr) -> do+ reqMVar <- newEmptyMVar+ respMVar <- newEmptyMVar+ connState <- newIORef Idle + runConceit $ + (Conceit $ fmap pure $ do+ flip runReaderT (reqMVar,respMVar,connState) transport+ <*+ atomicWriteIORef connState Finished+ <*+ putMVar reqMVar Nothing+ <* + liftIO ( shutdown sock ShutdownBoth )+ )+ <*+ (Conceit $ fmap pure $ runEffect $+ for (producerFromMVar reqMVar) + (yield . Data.Aeson.Encode.encode)+ >->+ toSocketLazy sock+ )+ <*+ (Conceit $ runEffect $ runExceptP $ + (jsonProducerFromSocket sock <* isPrematureClose connState) + >->+ connStateCheckerPipe connState+ >->+ hoist lift (consumerFromMVar respMVar)+ )+ where+ jsonProducerFromSocket sock = + hoist (withExceptT mkParsingError) $ + exceptP $+ view Pipes.Aeson.Unchecked.decoded (fromSocket sock 4096)+ isPrematureClose ior = do+ connState <- liftIO $ readIORef ior + case connState of+ Finished -> return ()+ _ -> lift $ throwE UnexpectedConnectionClose+ connStateCheckerPipe ior = forever $ do+ resp <- await+ connState <- liftIO $ readIORef ior + case connState of+ RequestSent -> yield resp+ _ -> lift $ throwE UnexpectedData+ mkParsingError (de,_) = RequestParsingError $ case de of+ AttoparsecError pe -> pe + FromJSONError _ -> error "never happens" + view l = getConst . l Const+ runExceptP = runExceptT . distribute+ exceptP p = do+ x <- unsafeHoist lift p+ lift $ ExceptT (return x)+