diff --git a/Control/Remote/Monad/JSON.hs b/Control/Remote/Monad/JSON.hs new file mode 100644 --- /dev/null +++ b/Control/Remote/Monad/JSON.hs @@ -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 + diff --git a/Control/Remote/Monad/JSON/Router.hs b/Control/Remote/Monad/JSON/Router.hs new file mode 100644 --- /dev/null +++ b/Control/Remote/Monad/JSON/Router.hs @@ -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 diff --git a/Control/Remote/Monad/JSON/Trace.hs b/Control/Remote/Monad/JSON/Trace.hs new file mode 100644 --- /dev/null +++ b/Control/Remote/Monad/JSON/Trace.hs @@ -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 diff --git a/Control/Remote/Monad/JSON/Types.hs b/Control/Remote/Monad/JSON/Types.hs new file mode 100644 --- /dev/null +++ b/Control/Remote/Monad/JSON/Types.hs @@ -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" + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# remote-json [![Build Status](https://img.shields.io/travis/ku-fpg/remote-json.svg?style=flat)](https://travis-ci.org/ku-fpg/remote-json) +JSON RPC using the remote monad + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/front/Main.hs b/front/Main.hs new file mode 100644 --- /dev/null +++ b/front/Main.hs @@ -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 diff --git a/remote-json-test/Unit.hs b/remote-json-test/Unit.hs new file mode 100644 --- /dev/null +++ b/remote-json-test/Unit.hs @@ -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 + ] diff --git a/remote-json.cabal b/remote-json.cabal new file mode 100644 --- /dev/null +++ b/remote-json.cabal @@ -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 + diff --git a/tests/qc/Test.hs b/tests/qc/Test.hs new file mode 100644 --- /dev/null +++ b/tests/qc/Test.hs @@ -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 _ = "" + +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 _ = "" + +---------------------------------------------------------------- + +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) + diff --git a/tests/spec/Spec.hs b/tests/spec/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/spec/Spec.hs @@ -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