butter (empty) → 0.1.0.0
raw patch · 12 files changed
+716/−0 lines, 12 filesdep +HUnitdep +aesondep +basesetup-changed
Dependencies added: HUnit, aeson, base, butter, bytestring, containers, forkable-monad, free, network-simple, stm, template-haskell, text, transformers
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +40/−0
- Setup.hs +2/−0
- butter.cabal +102/−0
- src/Distrib/Butter.hs +4/−0
- src/Distrib/Butter/Lang.hs +298/−0
- src/Distrib/Butter/Lib.hs +4/−0
- src/Distrib/Butter/Lib/K.hs +20/−0
- src/Distrib/Butter/Lib/Protocol.hs +53/−0
- test/first/Main.hs +92/−0
- test/protocol/Main.hs +68/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for Butter++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Matthew Ahrens, System in Dystress, and Sid.Run (c) 2018++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 Author name here nor the names of other+ 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+OWNER 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,40 @@+# Butter+For easily spreading around monadic computation+## Examples+- Example Language usage in `test/first/Main.hs`+- Example Protocol usage in `test/protocol/Main.hs`+## Current Language Features+Actor Monad Transformer that supports+- self+- send+- receive+ - selective based on type+ - yields on empty receive or type mismatch+- spawn+ - built on Forkable-Monad and forkIO+- lift+- named pids+- connect to remote+ - send via named++# Current Library Features+- Protocol (OTP Genserver like typeclass)+ - explicit State type family+ - explicit Monadic Context type family+ - Results API++## Future Core Language Features+- monitor+- serializable computation typeclass+ - spawn remote+ - monitor remote+- query remote+- encrypted message passing by default+ - config to change encode and decode++## Future Library Features+- quasiquoter / convenience Syntax+- OTP+ - supervisor trees+- haddock documentation+- versioned tutorial series
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ butter.cabal view
@@ -0,0 +1,102 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 607195c62d85e10a85cb8f34565dcf2d6823a6056b5d5fafe8a2ce460e361963++name: butter+version: 0.1.0.0+synopsis: Monad Transformer for Asyncronous Message Passing+description: Please see the README on Github at <https://github.com/System-Indystress/Butter#readme>+category: Distrbution, Concurrency+homepage: https://github.com/System-Indystress/Butter#readme+bug-reports: https://github.com/System-Indystress/Butter/issues+author: Matthew Ahrens+maintainer: matt.p.ahrens@gmail.com+copyright: 2018 SID.run+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/System-Indystress/Butter++library+ hs-source-dirs:+ src+ build-depends:+ HUnit+ , aeson+ , base <5+ , bytestring+ , containers+ , forkable-monad+ , free+ , network-simple+ , stm+ , template-haskell+ , text+ , transformers+ exposed-modules:+ Distrib.Butter+ Distrib.Butter.Lang+ Distrib.Butter.Lib+ Distrib.Butter.Lib.K+ Distrib.Butter.Lib.Protocol+ other-modules:+ Paths_butter+ default-language: Haskell2010++test-suite Lang-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs:+ test/first+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ HUnit+ , aeson+ , base <5+ , butter+ , bytestring+ , containers+ , forkable-monad+ , free+ , network-simple+ , stm+ , template-haskell+ , text+ , transformers+ other-modules:+ Paths_butter+ default-language: Haskell2010++test-suite Protocol-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs:+ test/protocol+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ HUnit+ , aeson+ , base <5+ , butter+ , bytestring+ , containers+ , forkable-monad+ , free+ , network-simple+ , stm+ , template-haskell+ , text+ , transformers+ other-modules:+ Paths_butter+ default-language: Haskell2010
+ src/Distrib/Butter.hs view
@@ -0,0 +1,4 @@+module Distrib.Butter where++import Distrib.Butter.Lang+import Distrib.Butter.Lib
+ src/Distrib/Butter/Lang.hs view
@@ -0,0 +1,298 @@+{-#LANGUAGE KindSignatures, GADTs, DeriveGeneric, OverloadedStrings, TemplateHaskell #-}+{-# LANGUAGE StandaloneDeriving, PatternSynonyms, FlexibleInstances #-}+module Distrib.Butter.Lang where++import Control.Monad.Trans.Except+import Data.Text+import Data.Aeson+import GHC.Generics+import Control.Concurrent.STM+import Control.Monad.IO.Class (liftIO, MonadIO(..))+import qualified Data.Map as M+import Data.Map (Map(..))+import Control.Exception+import System.IO.Error (isDoesNotExistError)+import Control.Monad.Free+import Network.Simple.TCP as N+import Control.Concurrent.Forkable+import Control.Concurrent (threadDelay)+import qualified Data.Sequence as Seq+import Data.Sequence (Seq(..),(<|),(|>))+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BW+import Data.ByteString(ByteString(..))+import qualified Data.ByteString.Lazy as LB+import qualified Data.Text.Encoding as E+import Debug.Trace (trace, traceIO)+import Control.Monad (forever, guard)+++data ProcessID = PID {machineID :: Text, processID :: Int}+ | Named {hostname :: Text, processName :: Text}+ deriving (Show, Eq, Generic)++to :: Text -> Text -> ProcessID+to = Named++instance ToJSON (ProcessID) where+ toEncoding = genericToEncoding defaultOptions++instance FromJSON (ProcessID)+++data Action (m :: * -> *) next where+ Lift :: m a+ -> (a -> next)+ -> Action m next+ Connect :: Text+ -> Text+ -> Int+ -> next+ -> Action m next+ Spawn :: Butter m ()+ -> (ProcessID -> next)+ -> Action m next+ Send :: ProcessID+ -> LB.ByteString+ -> next+ -> Action m next+ Receive :: (LB.ByteString -> next)+ -> Action m next+ Friends :: ([Text] -> next)+ -> Action m next+ Self :: (ProcessID -> next)+ -> Action m next+ Alive :: ProcessID+ -> (Bool -> next)+ -> Action m next+ Name :: Text+ -> next+ -> Action m next+++data Internal =+ Internal { machine :: (Text)+ , procs :: [(Int)]+ , names :: Map Text Int+ , fresh :: Int+ , friends :: Map Text Socket+ , mail :: Seq (ProcessID, ProcessID, LB.ByteString)+ }++instance Functor (Action m) where+ fmap f (Spawn body returnPID) = (Spawn body (f . returnPID))+ fmap f (Send pid msg next) = (Send pid msg $ f next)+ fmap f (Receive returnMSG) = (Receive $ f . returnMSG)+ fmap f (Connect name host port next) = (Connect name host port $ f next)+ fmap f (Friends returnFriends) = (Friends $ f . returnFriends)+ fmap f (Lift ma returnA) = (Lift ma $ f . returnA)+ fmap f (Self returnMe) = (Self $ f . returnMe)+ fmap f (Alive pid returnB) = (Alive pid $ f . returnB)+ fmap f (Name n next) = (Name n $ f next)++type Butter m a = Free (Action m) a++instance (MonadIO m) => MonadIO (Free (Action m)) where+ liftIO = lift . liftIO++connect :: Text -> Text -> Int -> Butter m ()+connect name host port = (Free (Connect name host port $ Pure ()))++spawn :: Butter m () -> Butter m ProcessID+spawn body = (Free (Spawn body (\i -> Pure i)))++self :: Butter m ProcessID+self = (Free (Self (\i -> Pure i)))++name :: Text -> Butter m ()+name n = (Free (Name n $ Pure ()))++send :: (ToJSON a) => ProcessID -> a -> Butter m ()+send to msg = (Free (Send to (encode msg) $ Pure ()))++receive :: (MonadIO m, FromJSON a) => Butter m a+receive =+ (Free $ Receive $ \msg ->+ case decode msg of+ Nothing -> do+ lift $ liftIO $ yield+ me <- self+ (Free $ Send me msg (Pure ()))+ receive+ Just a -> return a)++lift :: m a -> Butter m a+lift ma = Free (Lift ma $ \a -> Pure a)++alive :: ProcessID -> Butter m (Bool)+alive pid = (Free $ Alive pid $ \b -> Pure b)++spreadLocal :: (MonadIO m, ForkableMonad m, ToJSON a, FromJSON a)+ => Butter m a -> m a+spreadLocal = spread "local" Nothing++spread :: (MonadIO m, ForkableMonad m, ToJSON a, FromJSON a)+ => Text -> Maybe Int -> Butter m a -> m a+spread host mport actor =+ let+ getLength sock acc = do+ mbs <- recv sock 1+ case mbs of+ Nothing -> getLength sock acc+ Just char ->+ if char == "§" then return acc else getLength sock $ acc `B.append` char+ setup :: (MonadIO m, ForkableMonad m) => TVar Internal -> Maybe Int -> m ()+ setup var Nothing = return ()+ setup var (Just port) = do+ forkIO $ serve (HostAny) (show port) (\(sock,addr) -> do+ mbs <- recv sock 1+ if mbs /= Just (BW.pack "§")+ then return ()+ else do+ len <- getLength sock B.empty+ let len' = (read $ BW.unpack len) :: Int+ mbs' <- recv sock len'+ case mbs' of+ (Just payload) -> do+ atomically $ modifyTVar var (\s ->+ case (decode $ LB.fromStrict payload) of+ (Just (f, Named _ n, msg)) ->+ case M.lookup n (names s) of+ Just i -> s{mail = (f, (PID (machine s) i), LB.pack msg)<| (mail s)}+ Nothing -> s+ (Just (f,t,msg)) ->+ s{mail = (f, t, LB.pack msg)<| (mail s)}+ _ -> s)+ return ()+ _ -> return ())+ return ()++ eval :: (MonadIO m, ForkableMonad m, ToJSON a, FromJSON a) => Int -> TVar Internal -> Butter m a -> m a+ eval me stateVar (Pure a) = do+ liftIO $ atomically $ do+ i@(Internal { procs = ps }) <- readTVar stateVar+ writeTVar stateVar $ i {procs = Prelude.filter (\n -> n /= me) ps}+ return a+ eval me stateVar (Free (Name n next)) = do+ liftIO $ atomically $ modifyTVar stateVar $ (\s ->+ s {names = M.insert n me (names s)})+ eval me stateVar next+ eval me stateVar (Free (Alive (PID _ n) returnB)) = do+ i@(Internal {procs = ps}) <- liftIO $ readTVarIO stateVar+ eval me stateVar $ returnB $ elem n ps+ eval me stateVar (Free (Alive (Named h n) returnB)) = do+ i <- liftIO $ readTVarIO stateVar+ if (machine i) == h+ then case M.lookup n $ names i of+ Just pnum -> eval me stateVar $ returnB $ elem pnum (procs i )+ Nothing -> eval me stateVar $ returnB False+ else error "Unimplemented: Alive of remote processes"++ eval me stateVar (Free (Lift ma returnA)) = do+ a <- ma+ eval me stateVar $ returnA a+ eval me stateVar (Free (Friends returnFriends)) = do+ i@(Internal { machine = h+ , procs = ps+ , friends = fs+ , fresh = f+ , mail = m+ }) <- liftIO $ readTVarIO stateVar+ eval me stateVar $ returnFriends $ M.keys fs+ eval me stateVar (Free (Connect name host port rest)) = do+ conn <- liftIO $ tryJust (guard . isDoesNotExistError) $ connectSock (unpack host) (show port)+ case conn of+ Left _ -> do+ liftIO yield+ eval me stateVar (Free (Connect name host port rest))+ Right (sock,addr) -> do+ liftIO $ atomically $ modifyTVar stateVar $ (\s ->+ s {friends = M.insert name sock $ friends s})+ eval me stateVar rest++ eval me stateVar (Free (Spawn body returnPID)) = do+ (h,f) <-+ liftIO $ atomically $ do+ i@(Internal { machine = h+ , procs = ps+ , fresh = f+ }) <- readTVar stateVar+ writeTVar stateVar $ i {fresh = f + 1, procs = (f+1):ps}+ return (h,f+1)+ let pid = PID h (f)+ forkIO $ eval (f) stateVar body+ eval me stateVar (returnPID pid)+ eval me stateVar (Free (Self returnMe)) = do+ --trace "self" $ return ()+ Internal {machine = h} <- liftIO $ readTVarIO stateVar+ let s = PID h me+ eval me stateVar $ returnMe s+ eval me stateVar (Free (Send you msg next)) = do+ --trace "send" $ return ()+ meffect <-+ liftIO $ atomically $ do+ i@(Internal { machine = h+ , procs = ps+ , names = n+ , friends = fs+ , fresh = f+ , mail = m+ }) <- readTVar stateVar+ case you of+ Named h' p | h == h' ->+ case M.lookup p n of+ Nothing -> return Nothing+ Just pnum -> do+ writeTVar stateVar $+ i {mail = (PID h me,PID h pnum, msg) <| m}+ return Nothing+ Named h' p ->+ case M.lookup h' fs of+ Nothing -> return Nothing+ Just sock -> do+ let payload = LB.toStrict $ encode $ (PID h me, Named h' p, LB.unpack msg)+ return $ Just $ N.send sock (+ "§" `B.append` (BW.pack $ show $ (B.length payload)) `B.append` "§" `B.append` payload)+ pid -> do+ writeTVar stateVar $ i {mail = (PID h me,pid, msg) <| m}+ return Nothing+ case meffect of+ Just e -> liftIO e >> return ()+ Nothing -> return ()+ eval me stateVar next+ eval me stateVar (Free (Receive returnRest)) = (do+ mmsg <-+ liftIO $ atomically $ do+ i@(Internal { machine = h+ , procs = ps+ , friends = fs+ , fresh = f+ , mail = m+ }) <- readTVar stateVar+ let (mmsg,rest) = find (PID h me) m+ writeTVar stateVar $ i {mail = rest}+ return mmsg+ case mmsg of+ Just msg -> eval me stateVar (returnRest msg)+ Nothing -> do+ liftIO yield+ eval me stateVar (Free (Receive returnRest)))++ where+ find who Empty = (Nothing,Seq.empty)+ find who (rest :|> (from,to, msg))+ | to == who = (Just msg,rest)+ | otherwise = let (ans,rest') = find who rest+ in (ans,rest |> (from,to,msg))++ in do+ stateVar <- liftIO $ newTVarIO $+ Internal { machine = host+ , procs = [0]+ , names = M.empty+ , fresh = 1+ , friends = M.empty+ , mail = Seq.empty+ }+ setup stateVar mport+ eval 0 stateVar actor
+ src/Distrib/Butter/Lib.hs view
@@ -0,0 +1,4 @@+module Distrib.Butter.Lib where++import Distrib.Butter.Lib.K+import Distrib.Butter.Lib.Protocol
+ src/Distrib/Butter/Lib/K.hs view
@@ -0,0 +1,20 @@+{-#LANGUAGE KindSignatures, GADTs, DeriveGeneric, OverloadedStrings, TemplateHaskell #-}+{-# LANGUAGE StandaloneDeriving #-}+module Distrib.Butter.Lib.K where++import Distrib.Butter.Lang+import Data.Aeson+import GHC.Generics+import Control.Monad.Free++deriving instance Generic a => Generic (Free f a)++class (Monad m) => SerialM m where+ toV :: m a -> Value+ fromV :: Value -> m a++sendB :: (SerialM m, ToJSON a) => ProcessID -> Butter m a -> Butter m ()+sendB to program = undefined++receiveB :: (SerialM m, FromJSON a) => Butter m (Butter m a)+receiveB = undefined
+ src/Distrib/Butter/Lib/Protocol.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstrainedClassMethods, AllowAmbiguousTypes #-}++module Distrib.Butter.Lib.Protocol where+import Distrib.Butter.Lang++import Control.Concurrent.Forkable (ForkableMonad(..))+import Control.Monad.IO.Class (MonadIO(..))+import Data.Aeson (FromJSON(..), ToJSON(..))++data Result p = Reply p (State p)+ | NoReply (State p)+ | Terminate+ | Restart++class (ToJSON p, FromJSON p) => Protocol p where+ data State p+ type Context p :: * -> *+ setup :: (MonadIO (Context p), ForkableMonad (Context p))+ => p -> Butter (Context p) (State p)+ handle :: (MonadIO (Context p), ForkableMonad (Context p))+ => p -> State p -> Butter (Context p) (Result p)++start :: (MonadIO (Context p), ForkableMonad (Context p), Protocol p)+ => p -> Butter (Context p) (ProcessID)+start p =+ let server s = do+ (from,p') <- receive+ result <- handle p' s+ case result of+ Reply p'' s' -> do+ send from p''+ server s'+ NoReply s' -> server s'+ Terminate -> return ()+ Restart -> do+ s' <- setup p'+ server s'+ in do+ s <- setup p+ spawn $ server s++call :: (MonadIO (Context p), ForkableMonad (Context p), Protocol p)+ => ProcessID -> p -> Butter (Context p) p+call to p = do+ me <- self+ send to (me,p)+ receive++cast :: (MonadIO (Context p), ForkableMonad (Context p), Protocol p)+ => ProcessID -> p -> Butter (Context p) ()+cast to p = do+ me <- self+ send to (me,p)
+ test/first/Main.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Distrib.Butter.Lang+import Test.HUnit+import Data.Text+import Control.Concurrent (forkIO)+import Debug.Trace+import Control.Concurrent++butter1 :: Butter IO ()+butter1 = do+ me <- self+ send me (1 :: Int)+ y <- receive :: Butter IO Int+ lift $ assertEqual "send receive self Int msg" 1 y+ return ()++butter2 :: Butter IO ()+butter2 = do+ me <- self+ child <- spawn $ do+ x <- receive :: Butter IO Int+ send me (x+1)+ return ()+ send child (5 :: Int)+ y <- receive :: Butter IO Int+ lift $ assertEqual "spawn, send receive Int msg" 6 y+ return ()+++selective :: Butter IO ()+selective = do+ me <- self+ spawn $ do+ send me ("hello" :: String)+ send me True+ b <- receive :: Butter IO Bool+ s <- receive :: Butter IO String+ lift $ assertEqual "receive out of order by type" True b+ lift $ assertEqual "receive out of order by type" "hello" s+ return ()++distr :: IO ()+distr = do+ forkIO $ spread "node2" (Just 9669) $ do+ connect "friend" "127.0.0.1" 9696+ send (to "friend" "hello") ("*wave*" :: String)+ return ()+ spread "node1" (Just 9696) $ do+ name "hello"+ msg <- receive :: Butter IO String+ lift $ assertEqual "got the message from another node" "*wave*" msg+ return ()+ return ()++distr2 :: IO ()+distr2 = do+ forkIO $ spread "node1" (Just 8002) $ do+ name "ping"+ connect "node2" "127.0.0.1" 8003+ send (to "node2" "hello") ("ping" :: String)+ msg <- receive :: Butter IO String+ lift $ assertEqual "got message" "pong" msg+ return ()+ spread "node2" (Just 8003) $ do+ name "hello"+ connect "node1" "127.0.0.1" 8002+ who <- receive :: Butter IO String+ send (to "node1" (pack who)) ("pong" :: String)+ return ()+ return ()++++++main :: IO ()+main = do+ runTestTT $+ TestList [ TestLabel "self,send,receive" $+ TestCase $ spreadLocal butter1+ , TestLabel "self,send,receive,spawn" $+ TestCase $ spreadLocal butter2+ , TestLabel "receive out of order by type" $+ TestCase $ spreadLocal selective+ , TestLabel "two nodes communicating one way" $+ TestCase distr+ , TestLabel "sending an name over and replying" $+ TestCase distr2+ ]+ return ()
+ test/protocol/Main.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE TypeFamilies, DeriveGeneric #-}+module Main where++import Distrib.Butter.Lang+import Distrib.Butter.Lib.Protocol+import Test.HUnit++import Control.Monad.IO.Class (liftIO)+import Control.Concurrent (threadDelay)+import Data.Aeson+import GHC.Generics+data P = Reset+ | Val Int+ | Get+ | Add Int+ | Close+ deriving (Show, Eq, Generic)++instance FromJSON P+instance ToJSON P++instance Protocol P where+ data State P = PS Int+ type Context P = IO+ setup Reset = return (PS 0)+ setup _ = error "Starting protocol P under non-initial conditions"+ handle Reset _ = return $ NoReply (PS 0)+ handle (Val i) _ = return $ NoReply (PS i)+ handle Get (PS i) = return $ Reply (Val i) (PS i)+ handle (Add n) (PS m) = return $ NoReply $ PS $ n + m+ handle Close _ = return $ Terminate++main :: IO ()+main = do+ runTestTT $ TestCase $+ spreadLocal $ do+ node <- start Reset+ b1 <- alive node+ (Val i1) <- call node Get+ lift $ threadDelay 1000+ cast node $ Val 10+ lift $ threadDelay 1000+ (Val i2) <- call node Get+ lift $ threadDelay 1000+ cast node $ Add 5+ lift $ threadDelay 1000+ (Val i3) <- call node Get+ lift $ threadDelay 1000+ cast node $ Add 4+ lift $ threadDelay 1000+ (Val i4) <- call node Get+ lift $ threadDelay 1000+ cast node Reset+ lift $ threadDelay 1000+ (Val i5) <- call node Get+ lift $ threadDelay 1000+ cast node Close+ lift $ threadDelay 1000+ b2 <- alive node+ lift $ assertEqual "node is alive" True b1+ lift $ assertEqual "setup works" 0 i1+ lift $ assertEqual "cast val" 10 i2+ lift $ assertEqual "cast add" 15 i3+ lift $ assertEqual "cast add2" 19 i4+ lift $ assertEqual "cast reset" 0 i5+ lift $ assertEqual "node is dead" False b2+ return ()+ return ()