diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -35,6 +35,11 @@ spawn "someAddress" (static hello `cap` name) ``` +An example of sending static pointers and closures +through a communication channel is provided under +[examples/ClientServer.hs](examples/ClientServer.hs) +in the source repository. + `distributed-closure` does not implement sending/receiving/spawning closures - that's left for higher-level frameworks. Only closure creation, composition and (de)serialization. diff --git a/distributed-closure.cabal b/distributed-closure.cabal --- a/distributed-closure.cabal +++ b/distributed-closure.cabal @@ -1,5 +1,5 @@ name: distributed-closure -version: 0.4.0 +version: 0.4.1 synopsis: Serializable closures for distributed programming. description: See README. homepage: https://github.com/tweag/distributed-closure @@ -49,3 +49,14 @@ distributed-closure, hspec >= 2.1, QuickCheck >= 2.8 + +executable example-client-server + main-is: ClientServer.hs + hs-source-dirs: examples + default-language: Haskell2010 + ghc-options: -Wall + build-depends: base >= 4.8 + , async >= 2.1 + , binary >= 0.7 + , bytestring >= 0.10 + , distributed-closure diff --git a/examples/ClientServer.hs b/examples/ClientServer.hs new file mode 100644 --- /dev/null +++ b/examples/ClientServer.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StaticPointers #-} +{-# LANGUAGE TemplateHaskell #-} + +import Control.Concurrent.Async +import Control.Concurrent.Chan +import Control.Distributed.Closure +import Control.Distributed.Closure.TH +import Control.Monad (forever) +import Data.Binary +import qualified Data.ByteString.Lazy as BSL +import Data.Functor.Static +import Data.Typeable (Typeable) +import GHC.Generics +import GHC.StaticPtr + +-- | An instruction to the server. +data Instruction + = CallStatic StaticKey Int + -- ^ @CallStatic skFun arg@ + -- + -- Apply the function behind the 'StaticKey' @skFun@ to @arg@. + | CallClosure (Closure (Int -> Int)) Int + -- ^ @CallClosure cl arg@ + -- + -- Apply the closure @cl@ to @arg@. + deriving Generic +instance Binary Instruction + +-- | Handle an instruction by the client. +-- +-- This is where we resolve a 'StaticKey' +-- by looking up the 'StaticPtr' and dereferencing it. +-- +-- This is also where we resolve a 'Closure'. +handleInstruction :: Instruction -> IO (Maybe Int) +handleInstruction (CallStatic skey input) = do + mbSPtr <- unsafeLookupStaticPtr skey + return $ case mbSPtr of + Nothing -> Nothing + Just sptr -> + let fun = deRefStaticPtr sptr in + Just $ fun input +handleInstruction (CallClosure cl input) = + let fun = unclosure cl in + return $ Just $ fun input + +-- | Channel to which a client will send its request. +type ServerChan = Chan (BSL.ByteString, ResponseChan) + +-- | Channel to which the server will send its response. +type ResponseChan = Chan BSL.ByteString + +-- | Execute an action with a concurrent server thread. +-- +-- This mocks a network connection between a client and a server process. +-- For simplicity, the client and server run within the same process +-- and communicate through 'Chan's instead of sockets. +-- +-- The server listens on a channel for requests. +-- The client sends requests on that channel together with a response channel. +-- The server handles the request and sends the result on the response channel. +withServer :: (ServerChan -> IO ()) -> IO () +withServer action = do + serverChan <- newChan + let server = forever $ do + (body, responseChan) <- readChan serverChan + result <- case decodeOrFail body of + Left _ -> return Nothing + Right (_, _, instruction) -> handleInstruction instruction + writeChan responseChan (encode result) + withAsync server (\_ -> action serverChan) + +-- | A global function that can be packed into a 'CallStatic' instruction. +double :: Int -> Int +double = (*2) + +-- | A wrapper around 'Int' used to fulfill the 'Serializable' constraint, +-- so that it can be packed into a 'Closure'. +newtype SerializableInt = SI Int deriving (Generic, Typeable) +withStatic [d| + instance Binary SerializableInt + instance Typeable SerializableInt + |] + +-- | Demonstration of client server interactions. +main :: IO () +main = withServer $ \serverChan -> do + do + clientChan <- newChan + -- Obtain the 'StaticPtr' to the global function 'double' + -- using the 'static' keyword, enabled by the 'StaticPointers' extension. + -- Convert the 'StaticPtr' into a 'StaticKey' using 'staticKey', + -- so that it can be sent across the wire. + let fun = staticKey $ static double + request = encode $ CallStatic fun 4 + writeChan serverChan (request, clientChan) + result <- decode <$> readChan clientChan + putStrLn $ "double 4 = " ++ show (result :: Maybe Int) + do + clientChan <- newChan + -- Construct a 'Closure' that effectively captures a value + -- and represents a partially applied function. + -- The 'static' keyword is used to convert a lambda, + -- that doesn't capture any free variables, into a 'StaticPtr'. + -- Then we use 'staticMap' to partially apply the lambda within the closure. + let three = SI 3 + c = static (\(SI a) b -> a + b) + `staticMap` cpure closureDict three + request = encode $ CallClosure c 4 + writeChan serverChan (request, clientChan) + result <- decode <$> readChan clientChan + putStrLn $ "3 + 4 = " ++ show (result :: Maybe Int) diff --git a/src/Control/Distributed/Closure.hs b/src/Control/Distributed/Closure.hs --- a/src/Control/Distributed/Closure.hs +++ b/src/Control/Distributed/Closure.hs @@ -11,6 +11,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StaticPointers #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 800 @@ -39,6 +40,7 @@ import Control.Distributed.Closure.Internal import Data.Binary (Binary) import Data.Constraint (Dict(..)) +import Data.Typeable (Typeable) -- $static-dicts -- @@ -58,6 +60,13 @@ -- 'Control.Distributed.Closure.TH.withStatic' if it becomes too tedious. class c => Static c where closureDict :: Closure (Dict c) + +instance (Static c1, Static c2, Typeable c1, Typeable c2, (c1, c2)) => Static (c1, c2) where + closureDict = static pairDict `cap` closureDict `cap` closureDict + +-- Needs to be defined at top-level for GHC <8.4 compat. +pairDict :: Dict c1 -> Dict c2 -> Dict (c1, c2) +pairDict Dict Dict = Dict -- | A newtype-wrapper useful for defining instances of classes indexed by -- higher-kinded types. diff --git a/src/Control/Distributed/Closure/TH.hs b/src/Control/Distributed/Closure/TH.hs --- a/src/Control/Distributed/Closure/TH.hs +++ b/src/Control/Distributed/Closure/TH.hs @@ -92,7 +92,9 @@ -- @ -- -- You will probably want to enable @FlexibleContexts@ and @ScopedTypeVariables@ --- in modules that use 'withStatic'. +-- in modules that use 'withStatic'. 'withStatic' can also handle non-user +-- generated instances like 'Typeable' instances: just write @instance Typeable +-- T@. withStatic :: TH.DecsQ -> TH.DecsQ withStatic = (>>= go) where @@ -140,5 +142,9 @@ let staticins = TH.InstanceD staticcxt statichd methods #endif decls' <- go decls - return (ins : sigf : declf : staticins : decls') + case hd of + TH.AppT (TH.ConT nm) _ | nm == ''Typeable -> + return (sigf : declf : staticins : decls') + _ -> + return (ins : sigf : declf : staticins : decls') go (decl:decls) = (decl:) <$> go decls diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -19,7 +19,7 @@ import GHC.StaticPtr import Test.Hspec import Test.Hspec.QuickCheck -import Test.QuickCheck +import qualified Test.QuickCheck as QC data T a = T a data T1 a b = T1 a b @@ -38,16 +38,16 @@ -- * Basic generators (parameterized by size) -- | Generates a basic closure using @cpure@ -genPure :: forall a. (Static (Serializable a), Arbitrary a) => Int -> Gen (Closure a) +genPure :: forall a. (Static (Serializable a), QC.Arbitrary a) => Int -> QC.Gen (Closure a) genPure i = cpure (closureDict :: Closure (Dict (Serializable a))) <$> - resize (max 0 (i-1)) arbitrary + QC.resize (max 0 (i-1)) QC.arbitrary -- | Generates a basic closure using @closure@ -genStatic :: Arbitrary (StaticPtr a) => Int -> Gen (Closure a) +genStatic :: QC.Arbitrary (StaticPtr a) => Int -> QC.Gen (Closure a) -- static pointers are considered to contribute 0 to the size, hence ignore the -- size parameter. -genStatic _i = closure <$> arbitrary +genStatic _i = closure <$> QC.arbitrary -- | Reifies basic datatypes (they must be @Serializable@ types). Only two types -- here because we already have to enumerate a lot of cases manually (see below). @@ -55,18 +55,18 @@ TInt :: Type Int TBool :: Type Bool -instance Static (Serializable Int) where - closureDict = static Dict +instance Static (Binary Int) where closureDict = static Dict +instance Static (Typeable Int) where closureDict = static Dict -instance Static (Serializable Bool) where - closureDict = static Dict +instance Static (Binary Bool) where closureDict = static Dict +instance Static (Typeable Bool) where closureDict = static Dict -- | Existentially quantified version of 'Type'. So that they can be generated. data AType where AType :: Typeable a => Type a -> AType -instance Arbitrary (AType) where +instance QC.Arbitrary (AType) where arbitrary = - elements [ AType TInt, AType TBool ] + QC.elements [ AType TInt, AType TBool ] -- | Composed types. Very few choices because of the combinatorics. data Sig a where @@ -82,7 +82,7 @@ push _ (Two _ _ _) = Nothing -- | Non-recursive generator of atomic values for each type. -genSimple :: Sig a -> Int -> Gen (Closure a) +genSimple :: Sig a -> Int -> QC.Gen (Closure a) genSimple (Zero TInt) = genPure genSimple (Zero TBool) = genPure genSimple (One TInt TInt) = genStatic @@ -100,14 +100,14 @@ gflip :: (Typeable a, Typeable b, Typeable c) - => (Int -> Gen (Closure (a->b->c))) -> Int -> Gen (Closure (b->a->c)) + => (Int -> QC.Gen (Closure (a->b->c))) -> Int -> QC.Gen (Closure (b->a->c)) gflip g i = (cap (static flip)) <$> g i gap :: Typeable a - => (Int -> Gen (Closure (a->b))) - -> (Int -> Gen (Closure a)) - -> Int -> Gen (Closure b) + => (Int -> QC.Gen (Closure (a->b))) + -> (Int -> QC.Gen (Closure a)) + -> Int -> QC.Gen (Closure b) gap gf gx i = do f <- gf i x <- gx i @@ -115,18 +115,18 @@ -- | Generate closures of a given type by randomly choosing to make the closure -- a 'cap'. Stays within the boundaries of 'Sig' so that the type of the --- function is also 'Arbitrary'. -genClosure :: Sig a -> Int -> Gen (Closure a) +-- function is also 'QC.Arbitrary'. +genClosure :: Sig a -> Int -> QC.Gen (Closure a) genClosure sig size | size < 10 = genSimple sig size genClosure sig size = do - stop <- frequency [(2, return True), (1, return False)] + stop <- QC.frequency [(2, return True), (1, return False)] if stop then genSimple sig size else do let upper = div size 3 lower = max 0 (size - 1 - upper) - AType pivot <- arbitrary + AType pivot <- QC.arbitrary case push pivot sig of Nothing -> genSimple sig size Just sig' -> do @@ -141,30 +141,30 @@ -- Must be from explicit lists since static pointers are, well, static. The -- combinatorics is unpleasant. -instance Arbitrary (StaticPtr (Int -> Int)) where +instance QC.Arbitrary (StaticPtr (Int -> Int)) where arbitrary = - elements + QC.elements [ static id , static pred , static succ , static (3*) ] -instance Arbitrary (StaticPtr (Bool -> Int)) where +instance QC.Arbitrary (StaticPtr (Bool -> Int)) where arbitrary = - elements + QC.elements [ static (bool 0 1) , static (bool 57 42)] -instance Arbitrary (StaticPtr (Bool -> Bool)) where +instance QC.Arbitrary (StaticPtr (Bool -> Bool)) where arbitrary = - elements + QC.elements [ static id , static not ] -instance Arbitrary (StaticPtr (Int -> Int -> Int)) where +instance QC.Arbitrary (StaticPtr (Int -> Int -> Int)) where arbitrary = - elements + QC.elements [ static const , static (+) , static (*) @@ -172,24 +172,24 @@ , static (\x y -> 2*x + y) ] -instance Arbitrary (StaticPtr (Int -> Bool -> Int)) where +instance QC.Arbitrary (StaticPtr (Int -> Bool -> Int)) where arbitrary = - elements + QC.elements [ static const , static (\n b -> if b then n else -n) , static (bool 0) ] -instance Arbitrary (StaticPtr (Bool -> Bool -> Int)) where +instance QC.Arbitrary (StaticPtr (Bool -> Bool -> Int)) where arbitrary = - elements + QC.elements [ static (\x y -> bool 0 1 (x&&y)) , static (\x y -> bool 57 42 (x||y)) ] -instance Arbitrary (StaticPtr (Int -> Int -> Bool)) where +instance QC.Arbitrary (StaticPtr (Int -> Int -> Bool)) where arbitrary = - elements + QC.elements [ static (==) , static (>=) , static (<=) @@ -197,28 +197,28 @@ , static (>) ] -instance Arbitrary (StaticPtr (Bool -> Int -> Bool)) where +instance QC.Arbitrary (StaticPtr (Bool -> Int -> Bool)) where arbitrary = - elements + QC.elements [ static const , static (\b n -> b && (n >= 0)) , static (\b n -> b || (n < 0)) , static (\b n -> if b then n >=0 else n < 0) ] -instance Arbitrary (StaticPtr (Bool -> Bool -> Bool)) where +instance QC.Arbitrary (StaticPtr (Bool -> Bool -> Bool)) where arbitrary = - elements + QC.elements [ static (&&) , static (||)] -- * Instances -instance Arbitrary (Closure Int) where - arbitrary = sized $ genClosure (Zero TInt) +instance QC.Arbitrary (Closure Int) where + arbitrary = QC.sized $ genClosure (Zero TInt) -instance Arbitrary (Closure (Int -> Int)) where - arbitrary = sized $ genClosure (One TInt TInt) +instance QC.Arbitrary (Closure (Int -> Int)) where + arbitrary = QC.sized $ genClosure (One TInt TInt) instance Show (Closure a) where show _ = ""