remote-json (empty) → 0.2
raw patch · 12 files changed
+1213/−0 lines, 12 filesdep +QuickCheckdep +aesondep +attoparsecsetup-changed
Dependencies added: QuickCheck, aeson, attoparsec, base, bytestring, containers, exceptions, fail, natural-transformation, quickcheck-instances, random, remote-json, remote-monad, scientific, tasty, tasty-quickcheck, text, transformers, unordered-containers, vector
Files
- Control/Remote/Monad/JSON.hs +132/−0
- Control/Remote/Monad/JSON/Router.hs +145/−0
- Control/Remote/Monad/JSON/Trace.hs +69/−0
- Control/Remote/Monad/JSON/Types.hs +261/−0
- LICENSE +28/−0
- README.md +3/−0
- Setup.hs +2/−0
- front/Main.hs +38/−0
- remote-json-test/Unit.hs +29/−0
- remote-json.cabal +146/−0
- tests/qc/Test.hs +279/−0
- tests/spec/Spec.hs +81/−0
+ Control/Remote/Monad/JSON.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecursiveDo #-}++{-|+Module: Control.Remote.Monad.JSON where+Copyright: (C) 2015, The University of Kansas+License: BSD-style (see the file LICENSE)+Maintainer: Justin Dawson+Stability: Alpha+Portability: GHC+-}++module Control.Remote.Monad.JSON (+ -- * JSON-RPC DSL+ RPC, -- abstract+ method,+ notification,+ -- * Invoke the JSON RPC Remote Monad+ send,+ Session,+ weakSession,+ strongSession,+ applicativeSession,+ SendAPI(..),+ -- * Types+ Args(..)+ ) where++import Control.Monad.Fail() +import Control.Remote.Monad.JSON.Types+import Control.Monad.Catch()+import Control.Natural++import Data.Aeson+import Data.Text(Text)+import Control.Remote.Monad+import qualified Control.Remote.Monad.Packet.Weak as WP+import qualified Control.Remote.Monad.Packet.Strong as SP+import qualified Control.Remote.Monad.Packet.Applicative as AP+import qualified Data.HashMap.Strict as HM++-- | Sets up a JSON-RPC method call with the function name and arguments +method :: FromJSON a => Text -> Args -> RPC a+method nm args = RPC $ procedure $ Method nm args++-- | Sets up a JSON-RPC notification call with the function name and arguments+notification :: Text -> Args -> RPC ()+notification nm args = RPC $ command $ Notification nm args++runWeakRPC :: (SendAPI ~> IO) -> WP.WeakPacket Notification Method a -> IO a+runWeakRPC f (WP.Command n) = f (Async (toJSON $ NotificationCall $ n))+runWeakRPC f (WP.Procedure m) = do+ let tid = 1+ v <- f (Sync (toJSON $ mkMethodCall m tid))+ res <- parseReply v+ parseMethodResult m tid res ++runStrongRPC :: (SendAPI ~> IO) -> SP.StrongPacket Notification Method a -> IO a+runStrongRPC f packet = go packet ([]++)+ where+ go :: forall a . SP.StrongPacket Notification Method a -> ([Notification]->[Notification]) -> IO a+ go (SP.Command n cs) ls = go cs (ls . ([n] ++))+ go (SP.Done) ls = do+ let toSend = (map(toJSON . NotificationCall) (ls [])) + () <- sendBatchAsync f toSend+ return ()+ go (SP.Procedure m) ls = do + let tid = 1+ let toSend = (map (toJSON . NotificationCall) (ls []) ) ++ [toJSON $ mkMethodCall m tid]+ res <- sendBatchSync f toSend+ parseMethodResult m tid res+++sendBatchAsync :: (SendAPI ~> IO) -> [Value] -> IO ()+sendBatchAsync _ [] = return () -- never send empty packet+sendBatchAsync f [x] = f (Async x) -- send singleton packet+sendBatchAsync f xs = f (Async (toJSON xs)) -- send batch packet++-- There must be at least one command in the list+sendBatchSync :: (SendAPI ~> IO) -> [Value] -> IO (HM.HashMap IDTag Value)+sendBatchSync f xs = f (Sync (toJSON xs)) >>= parseReply -- send batch packet++runApplicativeRPC :: (SendAPI ~> IO) -> AP.ApplicativePacket Notification Method a -> IO a+runApplicativeRPC f packet = do + case AP.superCommand packet of+ Just a -> do () <- sendBatchAsync f (map toJSON $ ls0 [])+ return a+ Nothing -> do+ rs <- sendBatchSync f (map toJSON $ ls0 [])+ ff0 rs + + where + (ls0,ff0) = go packet 1 ++ go :: forall a . AP.ApplicativePacket Notification Method a -> IDTag+ -> ([JSONCall]->[JSONCall], (HM.HashMap IDTag Value -> IO a))+ go (AP.Pure a ) _tid = (id, \ _ -> return a)+ go (AP.Command aps n) tid = (ls . ([(NotificationCall n)] ++), ff)+ where (ls,ff) = go aps tid + go (AP.Procedure aps m ) tid = ( ls . ([mkMethodCall m tid]++)+ , \ mp -> ff mp <*> parseMethodResult m tid mp+ )+ where (ls, ff) = go aps (tid + 1)+ +-- | Takes a function that handles the sending of Async and Sync messages,+-- and sends each Notification and Method one at a time +weakSession :: (SendAPI :~> IO) -> Session+weakSession f = Session $ runMonad (nat $ runWeakRPC (run f))++-- | Takes a function that handles the sending of Async and Sync messages,+-- and bundles Notifications together terminated by an optional Method+strongSession :: (SendAPI :~> IO) -> Session+strongSession f = Session $ runMonad (nat $ runStrongRPC (run f))++-- | Takes a function that handles the sending of Async and Sync messages,+-- and bundles together Notifications and Procedures that are used in+-- Applicative calls+applicativeSession :: (SendAPI :~> IO) -> Session+applicativeSession f = Session $ runMonad (nat $ runApplicativeRPC (run f))++-- | Send RPC Notifications and Methods by using the given session+send :: Session -> RPC a -> IO a+send (Session f) (RPC m) = f # m+
+ Control/Remote/Monad/JSON/Router.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}++{-|+Module: Control.Remote.Monad.JSON.Router where+Copyright: (C) 2015, The University of Kansas+License: BSD-style (see the file LICENSE)+Maintainer: Justin Dawson+Stability: Alpha+Portability: GHC+-}++module Control.Remote.Monad.JSON.Router + ( -- * The server RPC router+ router+ -- * The datatype that represents what we receive and what we dispatch+ , ReceiveAPI(..)+ , Call(..)+ -- * Utilty methods+ , transport+ , methodNotFound+ , invalidParams+ , parseError + ) where+ +import Control.Monad.Catch+import Control.Remote.Monad.JSON.Types+import Control.Natural++import Data.Aeson+import Data.Text(Text)+import Data.Typeable+import qualified Data.Vector as V++-- | 'Call' is a user-visable deep embedding of a method or notification call.+-- Server's provide transformations on this to implement remote-side call dispatching.+data Call :: * -> * where+ CallMethod :: Text -> Args -> Call Value+ CallNotification :: Text -> Args -> Call ()++-- | "The Server MAY process a batch rpc call as a set of concurrent tasks,+-- processing them in any order and with any width of parallelism."+-- We control this using the first argument. +router :: MonadCatch m + => (forall a. [m a] -> m [a])+ -> (Call :~> m) -> (ReceiveAPI :~> m)+router s f = nat $ \ case+ (Receive v@(Object {})) -> simpleRouter f v+ (Receive (Array a)) + | V.null a -> return $ Just $ invalidRequest+ | otherwise -> do+ rs <- s (map (simpleRouter f) $ V.toList a)+ case [ v | Just v <- rs ] of+ [] -> return Nothing -- If there are no Response objects contained within the+ -- Response array as it is to be sent to the client,+ -- the server MUST NOT return an empty Array and should+ -- return nothing at all.+ vs -> return (Just (toJSON vs))+ (Receive _) -> return $ Just $ invalidRequest+ +-- The simple router handle a single call.+simpleRouter :: forall m . MonadCatch m + => (Call :~> m) + -> Value -> m (Maybe Value)+simpleRouter (Nat f) v = case call <$> fromJSON v of+ Success m -> m+ Error _ -> return $ Just $ invalidRequest+ where+ call :: JSONCall -> m (Maybe Value)+ call (MethodCall (Method nm args) tag) = (do+ r <- f (CallMethod nm args :: Call Value)+ return $ Just $ object+ [ "jsonrpc" .= ("2.0" :: Text)+ , "result" .= toJSON r+ , "id" .= tag+ ]) `catches` + [ Handler $ \ (_ :: MethodNotFound) -> + return $ Just $ toJSON + $ errorResponse (-32601) "Method not found" tag+ , Handler $ \ (_ :: InvalidParams) -> + return $ Just $ toJSON + $ errorResponse (-32602) "Invalid params" tag+ , Handler $ \ (_ :: SomeException) ->+ return $ Just $ toJSON + $ errorResponse (-32603) "Internal error" tag + ]+ call (NotificationCall (Notification nm args)) =+ (f (CallNotification nm args) >> return Nothing) `catchAll` \ _ -> return Nothing++-- | 'transport' connects the ability to recieve a message with the ability+-- to send a message. Typically this is done using TCP/IP and HTTP,+-- but we can simulate the connection here.++transport :: (Monad f) => (ReceiveAPI :~> f) -> (SendAPI :~> f)+transport f = nat $ \ case+ Sync v -> do+ r <- f # Receive v+ case r of+ Nothing -> fail "no result returned in transport"+ Just v0 -> return v0+ Async v -> do+ r <- f # Receive v+ case r of+ Nothing -> return ()+ Just v0 -> fail $ "unexpected result in transport: " ++ show v0+++errorResponse :: Int -> Text -> Value -> Value+errorResponse code msg theId = toJSON $+ ErrorResponse (ErrorMessage code msg) theId++invalidRequest :: Value+invalidRequest = errorResponse (-32600) "Invalid Request" Null+++-- | For use when parsing to a JSON value fails inside a server,+-- before calling the router+parseError :: Value+parseError = errorResponse (-32700) "Parse error" Null++data MethodNotFound = MethodNotFound + deriving (Show, Typeable)++instance Exception MethodNotFound++-- | Throw this exception when a 'JSONCall a -> IO a' fails to match a method+-- or notification.+methodNotFound :: MonadThrow m => m a+methodNotFound = throwM $ MethodNotFound++data InvalidParams = InvalidParams + deriving (Show, Typeable)++instance Exception InvalidParams++-- | Throw this for when a 'JSONCall a -> IO a' method matches, but has invalid params.+invalidParams :: MonadThrow m => m a+invalidParams = throwM $ InvalidParams
+ Control/Remote/Monad/JSON/Trace.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}++{-|+Module: Control.Remote.Monad.JSON.Debug where+Copyright: (C) 2015, The University of Kansas+License: BSD-style (see the file LICENSE)+Maintainer: Justin Dawson+Stability: Alpha+Portability: GHC+-}++module Control.Remote.Monad.JSON.Trace where+ +import Control.Remote.Monad.JSON.Types+import Control.Remote.Monad.JSON.Router (Call(..))+import Control.Monad.IO.Class(MonadIO,liftIO)+import Control.Natural+++import Data.Aeson+import qualified Data.Text.Lazy as LT+import Data.Text.Lazy.Encoding(decodeUtf8)+++-- | A tracing natural transformation morphism over the Session API.+traceSendAPI :: MonadIO m => String -> (SendAPI :~> m) -> (SendAPI :~> m)+traceSendAPI msg f = nat $ \ case+ (Sync v) -> do+ liftIO $ putStrLn $ msg ++ "--> " ++ LT.unpack (decodeUtf8 (encode v))+ r <- f # (Sync v)+ liftIO $ putStrLn $ msg ++ "<-- " ++ LT.unpack (decodeUtf8 (encode r))+ return r+ (Async v) -> do+ liftIO $ putStrLn $ msg ++ "--> " ++ LT.unpack (decodeUtf8 (encode v))+ () <- f # (Async v)+ liftIO $ putStrLn $ msg ++ "// No response"+ return ()++-- | A tracing natural transformation morphism over the Receive API.+traceReceiveAPI :: MonadIO m => String -> (ReceiveAPI :~> m) -> (ReceiveAPI :~> m)+traceReceiveAPI msg f = nat $ \ (Receive v) -> do+ liftIO $ putStrLn $ msg ++ "--> " ++ LT.unpack (decodeUtf8 (encode v))+ r <- f # (Receive v)+ case r of+ Nothing -> liftIO $ putStrLn $ msg ++ "// No response"+ Just _ -> liftIO $ putStrLn $ msg ++ "<-- " ++ LT.unpack (decodeUtf8 (encode r))+ return r++-- | A tracing natural transformation morphism over the Call API.+traceCallAPI :: MonadIO m => String -> (Call :~> m) -> (Call :~> m)+traceCallAPI msg f = nat $ \ case+ p@(CallMethod nm args) -> do+ let method = Method nm args :: Method Value+ liftIO $ putStrLn $ msg ++ " method " ++ show method+ r <- f # p+ liftIO $ putStrLn $ msg ++ " return " ++ LT.unpack (decodeUtf8 (encode r))+ return r+ p@(CallNotification nm args) -> do+ let n = Notification nm args+ liftIO $ putStrLn $ msg ++ " notification " ++ show n+ f # p
+ Control/Remote/Monad/JSON/Types.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE StandaloneDeriving #-}++{-|+Module: Control.Remote.Monad.JSON where+Copyright: (C) 2015, The University of Kansas+License: BSD-style (see the file LICENSE)+Maintainer: Justin Dawson+Stability: Alpha+Portability: GHC+-}++module Control.Remote.Monad.JSON.Types (+ -- * RPC Monad+ RPC(..)+ -- * 'Notification', 'Method' and 'Args'+ , Notification(..)+ , Method(..)+ , Args(..)+ -- * Non-GADT combination of 'Notification' and 'Method'+ , JSONCall(..)+ , mkMethodCall+ -- * Sending and Receiving APIs+ , SendAPI(..)+ , ReceiveAPI(..)+ -- * Session abstraction+ , Session(..)+ -- * Internal datatypes+ , ErrorMessage(..)+ , Response(..)+ , IDTag+ , Replies+ -- * Parsing Result+ , parseReply+ , parseMethodResult+ ) where++import Control.Applicative+import Control.Natural+import Control.Remote.Monad(RemoteMonad)++import Data.Aeson+import Data.Aeson.Types+import qualified Data.HashMap.Strict as HM+import Data.Text(Text, unpack)++import qualified Data.Text.Lazy as LT+import Data.Text.Lazy.Encoding(decodeUtf8)+import qualified Data.Vector as V+++-- | The basic command type+data Notification :: * where+ Notification :: Text -> Args -> Notification++deriving instance Show Notification++-- | The basic procedure type+data Method :: * -> * where+ Method :: FromJSON a => Text -> Args -> Method a++deriving instance Show (Method a)++-- | This is the non-GADT, JSON-serializable version of Notification and Method.+data JSONCall :: * where+ NotificationCall :: Notification -> JSONCall+ MethodCall :: ToJSON a => Method a -> Value -> JSONCall++-- | Internal type of our tags+type IDTag = Int++-- | Internal map of replies+type Replies = HM.HashMap IDTag Value++-- | The non-GADT version of MethodCall+mkMethodCall :: Method a -> IDTag -> JSONCall+mkMethodCall (Method nm args) tag = MethodCall (Method nm args :: Method Value) (Number (fromIntegral tag))++-- | parseReply parses the reply JSON Value into Map of IDTag+-- to specific result from remote method call.+-- This function supports both singleton and batch results+parseReply :: Monad m => Value -> m Replies+parseReply v = case fromJSON v of+ Success (rs :: [Value]) -> return $ results rs+ _ -> return $ results [v]+ + where+ results :: [Value] -> HM.HashMap IDTag Value+ results rs = foldl (\ acc v1 ->+ case fromJSON v1 of+ Success (Response v2 tag) -> + case fromJSON tag of+ Success t -> HM.insert t v2 acc+ _ -> error "ParseReply : Unable to obtain tag "+ Success (ErrorResponse msg tag) -> + case fromJSON tag of+ Success t -> HM.insert t (error $ show msg) acc+ _ -> error "ParseReply : Unable to obtain error tag "+ ) HM.empty rs++-- | parseMethodResult looks up a result in the finite map created from the result.+parseMethodResult :: (Monad m) => Method a -> IDTag -> Replies -> m a+parseMethodResult (Method {}) tag hm = case HM.lookup tag hm of+ Just x -> case fromJSON x of+ (Success v) -> return v+ _ -> fail $ "bad packet in parseMethodResult:" ++ show x + Nothing -> fail $ "Invalid id lookup in parseMethodResult:" ++ show tag+++instance Show JSONCall where+ show (MethodCall (Method nm args) tag) = unpack nm ++ show args ++ "#" ++ LT.unpack (decodeUtf8 (encode tag))+ show (NotificationCall (Notification nm args)) = unpack nm ++ show args++instance ToJSON JSONCall where+ toJSON (MethodCall (Method nm args) tag) = object $+ [ "jsonrpc" .= ("2.0" :: Text)+ , "method" .= nm+ , "id" .= tag+ ] ++ case args of+ None -> []+ _ -> [ "params" .= args ]+ toJSON (NotificationCall (Notification nm args)) = object $+ [ "jsonrpc" .= ("2.0" :: Text)+ , "method" .= nm+ ] ++ case args of+ None -> []+ _ -> [ "params" .= args ]+instance FromJSON JSONCall where + -- This douple-parses the params, an can be fixed+ parseJSON (Object o) = + ((\ nm args tag -> MethodCall (Method nm args :: Method Value) tag)+ <$> o .: "method"+ <*> (o .: "params" <|> return None)+ <*> o .: "id") <|>+ ((\ nm args -> NotificationCall (Notification nm args))+ <$> o .: "method"+ <*> (o .: "params" <|> return None))+ + parseJSON _ = fail "not an Object when parsing a JSONCall Value" ++-- | The JSON RPC remote monad+newtype RPC a = RPC (RemoteMonad Notification Method a)+ deriving (Functor, Applicative, Monad)+ +-- | The client-side send function API.+-- The user provides a way of dispatching this, to implement a client.+-- An example of this using wreq is found in remote-json-client+--+-- * For 'Sync', a JSON Value is send, and a JSON Value is received back as a reply.+-- * For 'Async', a JSON Value is send, and the reply, if any, is ignored.+data SendAPI :: * -> * where+ Sync :: Value -> SendAPI Value+ Async :: Value -> SendAPI ()++deriving instance Show (SendAPI a)++-- | The server-side recieived API.+-- The user provides a way of dispatching this, to implement a server.+-- An example of this using scotty is found in remote-json-server+data ReceiveAPI :: * -> * where+ Receive :: Value -> ReceiveAPI (Maybe Value)++deriving instance Show (ReceiveAPI a)++-- | Session is a handle used for where to send a sequence of monadic commands.+newtype Session = Session (RemoteMonad Notification Method :~> IO) +++-- | 'Args' follows the JSON-RPC spec: either a list of values,+-- or an (unordered) list of named fields, or none.+data Args where+ List :: [Value] -> Args+ Named :: [(Text,Value)] -> Args+ None :: Args++instance Show Args where+ show (List args) =+ if null args + then "()"+ else concat [ t : LT.unpack (decodeUtf8 (encode x))+ | (t,x) <- ('(':repeat ',') `zip` args + ] ++ ")"+ show (Named args) =+ if null args + then "{}"+ else concat [ t : show i ++ ":" ++ LT.unpack (decodeUtf8 (encode v))+ | (t,(i,v)) <- ('{':repeat ',') `zip` args + ] ++ "}"++ show None = ""++instance ToJSON Args where+ toJSON (List a) = Array (V.fromList a)+ toJSON (Named ivs) = object [ i .= v | (i,v) <- ivs ]+ toJSON None = Null+ +instance FromJSON Args where+ parseJSON (Array a) = return $ List (V.toList a)+ parseJSON (Object fm) = return $ Named (HM.toList fm)+ parseJSON Null = return $ None+ parseJSON _ = fail "parsing Args"++newtype Tag = Tag Value deriving Show++instance FromJSON Tag where + parseJSON (Object o) = Tag <$> o .: "id"+ parseJSON _ = fail "not an Object when parsing a Tag"+ +-- | internal. Used for error message.+data ErrorMessage = ErrorMessage Int Text+ deriving Show++instance ToJSON ErrorMessage where+ toJSON (ErrorMessage code msg) = object + [ "code" .= code+ , "message" .= msg+ ]++instance FromJSON ErrorMessage where+ parseJSON (Object o) = ErrorMessage+ <$> o .: "code"+ <*> o .: "message"+ parseJSON _ = fail "not an Object when parsing an ErrorMessage"++-- | internal. Used for responses.+data Response + = Response Value Value+ | ErrorResponse ErrorMessage Value+ deriving Show++instance ToJSON Response where+ toJSON (Response r theId) = object+ [ "jsonrpc" .= ("2.0" :: Text)+ , "result" .= r+ , "id" .= theId+ ]+ toJSON (ErrorResponse msg theId) = object+ [ "jsonrpc" .= ("2.0" :: Text)+ , "error" .= msg+ , "id" .= theId+ ]++instance FromJSON Response where+ parseJSON (Object o) = + pure Response <* (o .: "jsonrpc" :: Parser String) -- TODO: check this returns "2.0"+ <*> o .: "result"+ <*> o .: "id"+ <|> ErrorResponse <$> o .: "error"+ <*> o .: "id"+ parseJSON _ = fail "not an Object when parsing an Response"+
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2015, Functional Programming at the University of Kansas+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 remote-json 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,3 @@+# remote-json [](https://travis-ci.org/ku-fpg/remote-json)+JSON RPC using the remote monad+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ front/Main.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE GADTs, OverloadedStrings, TypeOperators #-}++module Main where++import Control.Natural ((:~>), nat)+import Control.Remote.Monad.JSON+import Control.Remote.Monad.JSON.Router(transport,router,Call(..),methodNotFound)+import Data.Aeson+import Data.Text(Text)++-- Our small DSL++say :: Text -> RPC ()+say msg = notification "say" (List [String msg])++temperature :: RPC Int+temperature = method "temperature" None++-- Our remote program++main :: IO ()+main = do+ let s = weakSession network+ t <- send s $ do+ say "Hello, "+ say "World!"+ temperature+ print t ++-- Simulate the JSON-RPC server++network :: SendAPI :~> IO+network = transport $ router sequence $ nat remote+ where+ remote :: Call a -> IO a+ remote (CallMethod "temperature" _) = return $ Number 42+ remote (CallNotification "say" (List [String msg])) = print msg+ remote _ = methodNotFound
+ remote-json-test/Unit.hs view
@@ -0,0 +1,29 @@+module Main where+ +import Untyped+import Typed+import DSL+import Session ++import Control.Remote.Monad.JSON+import Control.Remote.Monad.JSON.Router (transport)+import Control.Natural+++sessions :: [Session]+sessions = + [ sb $ transport $ rb + | sb <- sessionBuilders+ , rb <- routerBuilders+ ]++main:: IO()+main = do+ putStrLn "## Untyped ##"+ sequence_ [ untyped s+ | s <- sessions + ]+ putStrLn "## Typed ##"+ sequence_ [ typed (DSLSession s)+ | s <- sessions + ]
+ remote-json.cabal view
@@ -0,0 +1,146 @@+name: remote-json+version: 0.2+synopsis: Remote Monad implementation of the JSON RPC protocol+description: JSON RPC, where you can using monads and applicative functors+ to bundle JSON RPC methods and notifications.+ .+ @+ {-# LANGUAGE GADTs, OverloadedStrings, TypeOperators #-}+ .+ module Main where+ .+ import Control.Natural ((:~>), nat)+ import Control.Remote.Monad.JSON+ import Control.Remote.Monad.JSON.Router(transport,router,Call(..),methodNotFound)+ import Data.Aeson+ import Data.Text(Text)+ .+ -- Our small DSL+ .+ say :: Text -> RPC ()+ say msg = notification "say" (List [String msg])+ .+ temperature :: RPC Int+ temperature = method "temperature" None+ .+ -- Our remote program+ .+ main :: IO ()+ main = do+   let s = weakSession network+   t <- send s $ do+     say "Hello, "+     say "World!"+     temperature+   print t+ .+ -- Simulate the JSON-RPC server+ .+ network :: SendAPI :~> IO + network = transport $ router sequence $ nat remote+   where+     remote :: Call a -> IO a+     remote (CallMethod "temperature" _) = return $ Number 42+     remote (CallNotification "say" (List [String msg])) = print msg+     remote _ = methodNotFound+ @++license: BSD3+license-file: LICENSE+author: Justin Dawson and Andy Gill+maintainer: JDawson@ku.edu+copyright: (c) 2016 The University of Kansas+category: Network+build-type: Simple+extra-source-files: README.md+tested-with: GHC == 7.10.3+cabal-version: >=1.10++source-repository head+ type: git+ location: git://github.com/ku-fpg/remote-json++library+ exposed-modules: Control.Remote.Monad.JSON+ , Control.Remote.Monad.JSON.Router+ , Control.Remote.Monad.JSON.Trace++ other-modules:+ Control.Remote.Monad.JSON.Types++ build-depends: aeson >= 0.8 && < 0.12+ , base >= 4 && < 5+ , exceptions >= 0.8 && < 0.9+ , fail+ , transformers >= 0.4 && < 0.6+ , natural-transformation >= 0.3.1 && < 0.4+ , remote-monad == 0.2+ , text >= 1.2 && < 1.3+ , unordered-containers >= 0.2.5 && < 0.2.7+ , vector >= 0.11 && < 0.12+ hs-source-dirs: .+ default-language: Haskell2010+ ghc-options: -Wall+++Test-Suite test-spec+ type: exitcode-stdio-1.0+ hs-source-dirs: tests/spec+ main-is: Spec.hs+ build-depends: aeson >= 0.8 && < 0.12+ , attoparsec >= 0.13 && < 0.14+ , base >= 4 && < 5+ , bytestring >= 0.10 && < 0.11+ , natural-transformation >= 0.3.1 && < 0.4+ , remote-json == 0.2+ , text >= 1.2 && < 1.3++ default-language: Haskell2010+ ghc-options: -Wall+++Test-Suite test-example+ type: exitcode-stdio-1.0+ hs-source-dirs: remote-json-test+ main-is: Unit.hs+ build-depends: aeson >= 0.8 && < 0.12+ , base >= 4 && < 5+ , natural-transformation >= 0.3.1 && < 0.4+ , random >= 1.1 && < 1.2+ , remote-json == 0.2+ , scientific >= 0.3 && < 0.4+ , text >= 1.2 && < 1.3++ default-language: Haskell2010+ ghc-options: -Wall++Test-Suite front-example+ type: exitcode-stdio-1.0+ hs-source-dirs: front+ main-is: Main.hs+ build-depends: aeson >= 0.8 && < 0.12+ , base >= 4 && < 5+ , natural-transformation >= 0.3.1 && < 0.4+ , remote-json == 0.2+ , text >= 1.2 && < 1.3++ default-language: Haskell2010+ ghc-options: -Wall+++test-suite remote-json-properties+ type: exitcode-stdio-1.0+ main-is: Test.hs+ build-depends: aeson >= 0.8 && < 0.12+ , base >= 4.7 && < 5+ , containers >= 0.1 && < 0.6+ , natural-transformation >= 0.3.1 && < 0.4+ , remote-json == 0.2+ , QuickCheck == 2.8.*+ , quickcheck-instances >= 0.1 && < 0.4+ , tasty >= 0.8 && < 0.12+ , tasty-quickcheck >= 0.8 && < 0.9+ hs-source-dirs: tests/qc+ default-language: Haskell2010+ ghc-options: -Wall+
+ tests/qc/Test.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+Module: Main+Copyright: (C) 2015 The University of Kansas+License: BSD-style (see the file LICENSE)+Maintainer: Justin Dawson+Stability: Experimental++@QuickCheck@ properties for natural transformations.+-}+module Main (main) where++import Data.Aeson (Value(..), toJSON)+import Data.Foldable (toList)+import Data.Sequence (Seq, fromList)++import Control.Natural (nat)+import qualified Control.Remote.Monad.JSON as JSON+import qualified Control.Remote.Monad.JSON.Router as R+++import Test.QuickCheck +import Test.QuickCheck.Instances ()+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck.Poly (A(..))+import Test.QuickCheck.Monadic+import Test.QuickCheck.Gen.Unsafe (promote)++import Data.IORef++main :: IO ()+main = defaultMain testProperties++testProperties :: TestTree+testProperties = testGroup "QuickCheck remote monad properties"+ [ testProperty "push works remotely" $ prop_push+ , testProperty "pop works remotely" $ prop_pop + , testProperty "compare two remote monad strategies" $ testRunRemoteMonad+ , testProperty "send (m >>= k) = send m >>= send . k" $ testRemoteMonadBindLaw+ , testProperty "send (return a) = return a" $ testRemoteMonadReturnLaw+ ]+++----------------------------------------------------------------+-- Basic stack machine, with its interpreter+runCall :: IORef [String] -> IORef [A] -> R.Call a -> IO a+runCall tr ref (R.CallNotification "push" (JSON.List [Number n])) = do+ let a :: A = A (round n)+ stack <- readIORef ref+ writeIORef ref (a : stack)+ modifyIORef tr (("push " ++ show a) :)+ return ()+runCall tr ref (R.CallMethod "pop" _) = do+ modifyIORef tr (("pop") :)+ stack <- readIORef ref+ res <- case stack of+ [] -> return Nothing + (x:xs) -> do+ writeIORef ref xs+ modifyIORef tr ((show x) :)+ return (Just (unA x))+ return $ toJSON res+runCall tr ref _ = R.methodNotFound++----------------------------------------------------------------+-- The different ways of running remote monads.++data RemoteMonad = RemoteMonad String (forall a . IORef [String] -> IORef [A] -> JSON.RPC a -> IO a)++instance Show RemoteMonad where+ show (RemoteMonad msg _) = "Remote Monad: " ++ msg+ +instance Arbitrary RemoteMonad where+ arbitrary = elements + [ runWeakRPC+ , runStrongRPC+ , runApplicativeRPC+ ]++--- This is a complete enumeration of ways of building remote monads+ +runWeakRPC :: RemoteMonad+runWeakRPC = RemoteMonad "WeakPacket" + $ \ tr ref -> JSON.send (JSON.weakSession (R.transport (R.router sequence (nat $ runCall tr ref))))++runStrongRPC :: RemoteMonad+runStrongRPC = RemoteMonad "StrongPacket" + $ \ tr ref -> JSON.send (JSON.strongSession (R.transport (R.router sequence (nat $ runCall tr ref))))++runApplicativeRPC :: RemoteMonad+runApplicativeRPC = RemoteMonad "ApplicativePacket" + $ \ tr ref -> JSON.send (JSON.applicativeSession (R.transport (R.router sequence (nat $ runCall tr ref))))+++----------------------------------------------------------------++data DeviceM = Device (IORef [String]) (IORef [A]) (forall a . JSON.RPC a -> IO a)++sendM :: DeviceM -> JSON.RPC a -> IO a+sendM (Device _ _ f) = f++newDevice :: [A] + -> RemoteMonad+ -> IO DeviceM+newDevice xs (RemoteMonad _ f) = do+ tr <- newIORef []+ ref <- newIORef xs+ return $ Device tr ref $ f tr ref++readDevice :: DeviceM -> IO [A]+readDevice (Device _ ref _) = readIORef ref++cmpDevices :: DeviceM -> DeviceM -> IO Bool+cmpDevices d1 d2 = (==) <$> readDevice d1 <*> readDevice d2++-- returns backwards, but is for cmp or debugging anyway+traceDevice :: DeviceM -> IO [String]+traceDevice (Device tr _ _) = readIORef tr ++----------------------------------------------------------------++push :: A -> JSON.RPC ()+push (A n) = JSON.notification "push" $ JSON.List [Number $ fromIntegral $ n]++pop :: JSON.RPC (Maybe A)+pop = fmap (fmap A) $ JSON.method "pop" $ JSON.None++----------------------------------------------------------------++newtype Remote a = Remote (JSON.RPC a)++instance Show (Remote a) where+ show _ = "<REMOTE>"++instance Arbitrary (Remote A) where+ arbitrary = sized $ \ n -> Remote <$> arbitraryRemoteMonadA n++----------------------------------------------------------------++data RemoteBind :: * -> * where+ RemoteBind :: Arbitrary a => JSON.RPC a -> (a -> JSON.RPC b) -> RemoteBind b++instance Show (RemoteBind a) where+ show _ = "<REMOTEBIND>"++----------------------------------------------------------------++arbitraryRemoteMonad' :: (CoArbitrary a, Arbitrary a) => [Gen (JSON.RPC a)] -> Int -> Gen (JSON.RPC a)+arbitraryRemoteMonad' base 0 = oneof base +arbitraryRemoteMonad' base n = frequency + [ (1 , oneof base)+ , (1 , do RemoteBind m k <- arbitraryBind (arbitraryRemoteMonad' base) n+ return (m >>= k)+ )+ , (1 , do m1 <- arbitraryRemoteMonadA (n `div` 2)+ m2 <- arbitraryRemoteMonad' base (n `div` 2)+ return (m1 >> m2)+ )+ , (1 , do m1 <- arbitraryRemoteMonadA (n `div` 2)+ m2 <- arbitraryRemoteMonad' base (n `div` 2)+ f <- arbitrary+ return (fmap f m1 <*> m2)+ )+ , (1 , do m1 <- arbitraryRemoteMonadA (n `div` 2)+ m2 <- arbitraryRemoteMonad' base (n `div` 2)+ return (m1 *> m2)+ )+ , (1 , do m1 <- arbitraryRemoteMonadA (n `div` 2)+ m2 <- arbitraryRemoteMonad' base (n `div` 2)+ return (m2 <* m1) -- reversed, because we want to return m2's result+ )+ ]++arbitraryRemoteMonadUnit :: Int -> Gen (JSON.RPC ())+arbitraryRemoteMonadUnit = arbitraryRemoteMonad'+ [ return (return ())+ , push <$> arbitrary+ ]++arbitraryRemoteMonadMaybeA :: Int -> Gen (JSON.RPC (Maybe A))+arbitraryRemoteMonadMaybeA = arbitraryRemoteMonad'+ [ return <$> arbitrary+ , return $ pop+ ]++arbitraryRemoteMonadA :: Int -> Gen (JSON.RPC A)+arbitraryRemoteMonadA = arbitraryRemoteMonad'+ [ return <$> arbitrary+ ]++arbitraryBind :: (Int -> Gen (JSON.RPC a)) -> Int -> Gen (RemoteBind a)+arbitraryBind f n = oneof+ [ do m <- arbitraryRemoteMonadUnit (n `div` 2)+ k <- promote (`coarbitrary` f (n `div` 2)) -- look for a better way of doing this+ return $ RemoteBind m k+ , do m <- arbitraryRemoteMonadMaybeA (n `div` 2)+ k <- promote (`coarbitrary` f (n `div` 2)) + return $ RemoteBind m k+ , do m <- arbitraryRemoteMonadA (n `div` 2)+ k <- promote (`coarbitrary` f (n `div` 2)) + return $ RemoteBind m k+ ]++--------------------------------------------------------------------------++-- Test the remote push primitive+prop_push :: RemoteMonad -> [A] -> A -> Property+prop_push runMe xs x = monadicIO $ do+ dev <- run $ newDevice xs runMe+ () <- run $ sendM dev (push x)+ ys <- run $ readDevice dev+ assert (ys == (x : xs))++-- Test the remote pop primitive+prop_pop :: RemoteMonad -> [A] -> Property+prop_pop runMe xs = monadicIO $ do+ dev <- run $ newDevice xs runMe+ r <- run $ sendM dev pop+ ys <- run $ readDevice dev+ case xs of+ [] -> assert (r == Nothing && ys == [])+ (x':xs') -> assert (r == Just x' && ys == xs')++-- Check that two remote monad configurations given the same trace and same result+testRunRemoteMonad :: RemoteMonad -> RemoteMonad -> Remote A -> [A] -> Property+testRunRemoteMonad runMe1 runMe2 (Remote m) xs = monadicIO $ do+ dev1 <- run $ newDevice xs runMe1+ r1 <- run $ sendM dev1 m+ tr1 <- run $ traceDevice dev1+ st1 <- run $ readDevice dev1++ dev2 <- run $ newDevice xs runMe2+ r2 <- run $ sendM dev2 m+ tr2 <- run $ traceDevice dev2+ st2 <- run $ readDevice dev2+ +-- monitor $ collect $ (tr1,tr2)+ assert (r1 == r2 && tr1 == tr2 && st1 == st2)+ +-- Check remote monad laws+testRemoteMonadBindLaw :: RemoteMonad -> [A] -> Property+testRemoteMonadBindLaw runMe xs = monadicIO $ do+ RemoteBind m k <- pick (sized $ arbitraryBind arbitraryRemoteMonadA)++ dev1 <- run $ newDevice xs runMe+ a <- run $ sendM dev1 m+ r1 <- run $ sendM dev1 (k a)+ tr1 <- run $ traceDevice dev1+ st1 <- run $ readDevice dev1++ dev2 <- run $ newDevice xs runMe+ r2 <- run $ sendM dev2 (m >>= k)+ tr2 <- run $ traceDevice dev2+ st2 <- run $ readDevice dev2++-- monitor $ collect $ (runMe, tr1)+ assert (r1 == r2 && tr1 == tr2 && st1 == st2)++-- Check remote monad laws+testRemoteMonadReturnLaw :: RemoteMonad -> [A] -> A -> Property+testRemoteMonadReturnLaw runMe xs x = monadicIO $ do++ dev1 <- run $ newDevice xs runMe+ x' <- run $ sendM dev1 (return x)+ tr1 <- run $ traceDevice dev1+ st1 <- run $ readDevice dev1++-- monitor $ collect $ (runMe, tr1)+ assert (x == x' && tr1 == [] && st1 == xs)+
+ tests/spec/Spec.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++module Main where++import Control.Natural+import Data.Aeson+import Data.Aeson.Types+import Data.Maybe++import Data.Text(Text, append, pack, unpack)+import qualified Data.Text.IO as TIO+import qualified Data.Text.Lazy as LT+import Data.Text.Lazy.Encoding(decodeUtf8)++import Control.Monad (when)+import Control.Remote.Monad.JSON.Router+import Control.Remote.Monad.JSON+import Data.Attoparsec.ByteString+import System.Exit+import Test (readTests, Test(..))++f :: Call a -> IO a+f (CallMethod "subtract" (List [Number a,Number b])) = return $ Number (a - b)+f (CallMethod "subtract" (Named xs))+ | Just (Number a) <- lookup "minuend" xs+ , Just (Number b) <- lookup "subtrahend" xs+ = return $ Number (a - b)+f (CallMethod "sum" args) = case args of+ List xs -> return $ Number $ sum $ [ x | Number x <- xs ]+ _ -> invalidParams+f (CallMethod "get_data" None) = return $ toJSON [String "hello", Number 5]+f (CallMethod "error" (List [String msg])) = error $ show msg+f (CallMethod "fail" (List [String msg])) = fail $ show msg+f (CallNotification "update" _) = return $ ()+f (CallNotification "notify_hello" _) = return $ ()+f (CallNotification "notify_sum" _) = return $ ()+f _ = methodNotFound++main = do+ tests <- readTests "tests/spec/Spec.txt"+ let testWith i testName (Right v_req) v_expect = do+ putStrLn $ ("--> " ++) $ LT.unpack $ decodeUtf8 $ encode v_req+ r <- router sequence (nat f) # (Receive v_req)+ showResult i testName r v_expect+ testWith i testName (Left bad) v_expect = do+ putStr "--> " + TIO.putStr $ bad+ let r = Just $ parseError+ showResult i testName r v_expect+ showResult i testName Nothing v_expect = do+ testResult i testName Nothing v_expect+ showResult i testName (Just v_resp) v_expect = do+ putStrLn $ ("<-- " ++) $ LT.unpack $ decodeUtf8 $ encode v_resp+ testResult i testName (Just v_resp) v_expect+ + testResult i testName r v_expect = do+ r <- if (r /= v_expect) + then do putStrLn $ ("exp " ++) $ LT.unpack $ decodeUtf8 $ encode v_expect+ return $ Just (i,testName)+ else return Nothing+ putStrLn ""+ return r++ + res <- sequence + [ do when (i == 1) $ do+ putStr "#" + TIO.putStrLn $ testName+ testWith i testName v_req v_expect+ | (Test testName subTests) <- tests+ , (i,(v_req,v_expect)) <- [1..] `zip` subTests+ ]+ let failing = [ x | Just x <- res ]+ if (null failing)+ then putStrLn $ "ALL " ++ show (length res) ++ " TEST(S) PASS"+ else do + putStrLn $ show (length failing) ++ " test(s) failed"+ putStrLn $ unlines $ map show failing+ exitFailure