diff --git a/HasChor.cabal b/HasChor.cabal new file mode 100644 --- /dev/null +++ b/HasChor.cabal @@ -0,0 +1,196 @@ +cabal-version: 2.4 +name: HasChor +version: 0.1.0.1 +synopsis: Functional choreographic programming in Haskell +license: BSD-3-Clause +license-file: LICENSE +author: Gan Shen +maintainer: Gan Shen +copyright: (c) Gan Shen 2022 +category: Concurrency +description: + HasChor is a library for functional choreographic programming in Haskell. + See the README.md for more information. + +tested-with: + GHC == 9.6.3 + GHC == 9.4.7 + GHC == 9.2.8 + +extra-doc-files: + README.md + +source-repository head + type: git + location: https://github.com/gshen42/HasChor + +source-repository this + type: git + location: https://github.com/gshen42/HasChor + tag: v0.1.0.1 + +library + hs-source-dirs: src + default-language: GHC2021 + exposed-modules: + Choreography + Choreography.Choreo + Choreography.Location + Choreography.Network + Choreography.Network.Http + Choreography.Network.Local + Control.Monad.Freer + build-depends: + , base >= 4.16 && < 4.20 + , bytestring >= 0.11 && < 0.13 + , http-client >= 0.7 && < 0.8 + , servant >= 0.19 && < 0.21 + , servant-client >= 0.19 && < 0.21 + , servant-server >= 0.19 && < 0.21 + , template-haskell >= 2.18 && < 2.22 + , unordered-containers >= 0.2 && < 0.3 + , warp >= 3.3 && < 3.4 + +executable bank-2pc + hs-source-dirs: examples/bank-2pc + main-is: Main.hs + default-language: GHC2021 + build-depends: + , HasChor + , base >= 4.16 && < 4.20 + , split >= 0.2 && < 0.3 + , time >= 1.11 && < 1.13 + +executable bookseller-0-network + hs-source-dirs: examples/bookseller-0-network + main-is: Main.hs + default-language: GHC2021 + build-depends: + , HasChor + , base >= 4.16 && < 4.20 + , time >= 1.11 && < 1.13 + +executable bookseller-1-simple + hs-source-dirs: examples/bookseller-1-simple + main-is: Main.hs + default-language: GHC2021 + build-depends: + , HasChor + , base >= 4.16 && < 4.20 + , time >= 1.11 && < 1.13 + +executable bookseller-2-higher-order + hs-source-dirs: examples/bookseller-2-higher-order + main-is: Main.hs + default-language: GHC2021 + build-depends: + , HasChor + , base >= 4.16 && < 4.20 + , time >= 1.11 && < 1.13 + +executable bookseller-3-loc-poly + hs-source-dirs: examples/bookseller-3-loc-poly + main-is: Main.hs + default-language: GHC2021 + build-depends: + , HasChor + , base >= 4.16 && < 4.20 + , time >= 1.11 && < 1.13 + +executable diffiehellman + hs-source-dirs: examples/diffiehellman + main-is: Main.hs + default-language: GHC2021 + build-depends: + , HasChor + , base >= 4.16 && < 4.20 + , random >= 1.2 && < 1.3 + , time >= 1.11 && < 1.13 + +executable karatsuba + hs-source-dirs: examples/karatsuba + main-is: Main.hs + default-language: GHC2021 + build-depends: + , HasChor + , async >= 2.2 && < 2.3 + , base >= 4.16 && < 4.20 + , containers >= 0.6 && < 0.7 + +executable kvs1 + hs-source-dirs: examples/kvs-1-simple + main-is: Main.hs + default-language: GHC2021 + build-depends: + , HasChor + , base >= 4.16 && < 4.20 + , containers >= 0.6 && < 0.7 + , time >= 1.11 && < 1.13 + +executable kvs2 + hs-source-dirs: examples/kvs-2-primary-backup + main-is: Main.hs + default-language: GHC2021 + build-depends: + , HasChor + , base >= 4.16 && < 4.20 + , containers >= 0.6 && < 0.7 + , time >= 1.11 && < 1.13 + +executable kvs3 + hs-source-dirs: examples/kvs-3-higher-order + main-is: Main.hs + default-language: GHC2021 + build-depends: + , HasChor + , base >= 4.16 && < 4.20 + , containers >= 0.6 && < 0.7 + , time >= 1.11 && < 1.13 + +executable kvs4 + hs-source-dirs: examples/kvs-4-loc-poly + main-is: Main.hs + default-language: GHC2021 + build-depends: + , HasChor + , base >= 4.16 && < 4.20 + , containers >= 0.6 && < 0.7 + , time >= 1.11 && < 1.13 + +executable mergesort + hs-source-dirs: examples/mergesort + main-is: Main.hs + default-language: GHC2021 + build-depends: + , HasChor + , base >= 4.16 && < 4.20 + , containers >= 0.6 && < 0.7 + , time >= 1.11 && < 1.13 + +executable quicksort + hs-source-dirs: examples/quicksort + main-is: Main.hs + default-language: GHC2021 + build-depends: + , HasChor + , async >= 2.2 && < 2.3 + , base >= 4.16 && < 4.20 + , containers >= 0.6 && < 0.7 + , time >= 1.11 && < 1.13 + +executable ring-leader + hs-source-dirs: examples/ring-leader + main-is: Main.hs + default-language: GHC2021 + build-depends: + , HasChor + , base >= 4.16 && < 4.20 + , transformers >= 0.5 && < 0.7 + +executable playground + hs-source-dirs: examples/playground + main-is: Main.hs + default-language: GHC2021 + build-depends: + , HasChor + , base >= 4.16 && < 4.20 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2022, Gan Shen + +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 Gan Shen 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,175 @@ +# HasChor + +HasChor is a library for *functional choreographic programming* in Haskell, introduced by our [ICFP 2023 paper](https://doi.org/10.1145/3607849). +Choreographic programming is a programming paradigm where one writes a single program that describes the complete behavior of a distributed system and then compiles it to individual programs that run on each node. +In this way, the generated programs are guaranteed to be *deadlock-free*. + +HasChor has the following features: +- HasChor provides a *monadic* interface for choreographic programming where choreographies are expressed as computations in a monad. +- HasChor is implemented as an *embedded* domain-specific language, enabling it to inherent features and libraries from Haskell for free. +- HasChor is built on top of *freer monads*, leading to a flexible, extensible, and concise implementation. + +You can find the API specification [here](https://gshen42.github.io/HasChor/). + +## Usage + +### From Hackage + +Simply list `HaChor` in your cabal `build-depends` field, and you're ready to go! + +### From the Source Repository + +Create a `cabal.project` file and list HasChor's repository as an external source: + +``` cabal-config +packages: + . -- your package + +source-repository-package + type: git + location: https://github.com/gshen42/HasChor.git + branch: main +``` + +Alternatively, if you want to make changes to HasChor, you could clone the repository and list it as a local package in the `cabal.project` file: + +``` cabal-config +packages: + . -- your package + ./HasChor -- path to HasChor repository +``` + +Either way, you can then list `HasChor` as a dependency in your `.cabal` file: + +``` cabal-config +build-depends: + , base + , HasChor +``` + +## A Tour of HasChor + +Let's say we want to implement a bookshop protocol with three participants: a buyer, a seller, and a deliverer. +The protocol goes as follows: + +1. The buyer sends the title of a book they want to buy to the seller. +2. The seller replies to the buyer with the price of the book. +3. The buyer decides whether or not to buy the book based on their budget. + 1. If yes. The seller sends the title to the deliverer and gets back a delivery date, then forwards it to the buyer. + 2. If no. The protocol ends. + +In HasChor, we could implement the bookshop protocol as the following program: + +``` haskell +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeOperators #-} + +module Main where + +import Choreography (Choreo, cond, locally, mkHttpConfig, + runChoreography, type (@), (~>)) +import Control.Monad (void) +import Data.Proxy (Proxy (..)) +import System.Environment (getArgs) + +buyer :: Proxy "buyer" +buyer = Proxy + +seller :: Proxy "seller" +seller = Proxy + +deliverer :: Proxy "deliverer" +deliverer = Proxy + +priceOf :: String -> Int +priceOf "Types and Programming Languages" = 80 +priceOf "Homotopy Type Theory" = 120 +priceOf _ = 100 + +type Date = String + +deliveryDateOf :: String -> Date +deliveryDateOf "Types and Programming Languages" = "2002-01-04" +deliveryDateOf "Homotopy Type Theory" = "2013-04-20" +deliveryDateOf _ = "1970-01-01" + +budget :: Int +budget = 100 + +bookshop :: Choreo IO (Maybe Date @ "buyer") +bookshop = do + title <- buyer `locally` \un -> getLine + title' <- (buyer, title) ~> seller + + price <- seller `locally` \un -> return $ priceOf (un title') + price' <- (seller, price) ~> buyer + + decision <- buyer `locally` \un -> return $ (un price') <= budget + cond (buyer, decision) \case + True -> do + title'' <- (seller, title') ~> deliverer + date <- deliverer `locally` \un -> return $ deliveryDateOf (un title'') + date' <- (deliverer, date) ~> seller + date'' <- (seller, date') ~> buyer + buyer `locally` \un -> do + putStrLn $ "The book will be delivered on " ++ (un date'') + return $ Just (un date'') + False -> + buyer `locally` \un -> do + putStrLn "The book is out of the budget" + return Nothing + +main :: IO () +main = do + [loc] <- getArgs + void $ runChoreography cfg bookshop loc + where + cfg = mkHttpConfig + [ ("buyer", ("localhost", 4242)) + , ("seller", ("localhost", 4343)) + , ("deliverer", ("localhost", 4444)) + ] +``` + +First, we define a set of locations we will use in the choreography. +Locations are HasChor's abstraction for nodes in a distributed system — they are just `String`s. +Since HasChor also uses locations at the type level, we turn on the `DataKinds` extension and define term-level `Proxy`s (`buyer`, `seller`, `deliverer`) for them. + +Next, we have some auxiliary definitions (`priceOf`, `deliveryDateOf`, `budget`) for use in the choreography. + +`bookshop` is a choreography that implements the bookshop protocol: + +- `Choreo m a` is a monad that represents a choreography that returns a value of type `a`. + The `m` parameter is another monad that represents the local computation that locations can perform. + +- `a @ l` is a located value that represents a value of type `a` at location `l`. + It's kept opaque to the user to avoid misusing values at locations they're not at. + +- `locally :: Proxy l -> (Unwrap l -> m a) -> Choreo m (a @ l)` is the operator for performing a local compuation at a location. + It takes a location `l`, a local computation `m a` with access to a unwrap function, and returns a value at `l`. + The unwrap function is of type `Unwrap l = a @ l -> a`, which can only unwrap values at `l`. + +- `(~>) :: (Proxy l, a @ l) -> Proxy l' -> Choreo m (a @ l')` is the operator for communication between two locations. + It turns a value at `l` to the same value at `l'`. + +- `cond :: (Proxy l, a @ l) -> (a -> Choreo m b) -> Choreo m b` is the operator for conditional execution. + It takes a condition `a` at `l`, a function `a -> Choreo m b` denoting branches, and returns one of the branches. + +Finally, we use `runChoreography :: Backend cfg => cfg -> Choreo m a -> String -> m a` to project the choreography to a particular location and run the resulting program. +`runChoregraphy` takes a *backend configuration* cfg which specifies the message transport backend that acutally handles sending and receives messages. + +## More Examples + +HasChor comes with a set of illustrative examples in the [examples](examples) directory. +They are built as executables alongside the HasChor library and can be run with: + +``` bash +cabal run executable-name location +``` + +## Further Readings + +- [Introduction to Choreographies](https://www.fabriziomontesi.com/introduction-to-choreographies/) +- [Pirouette: higher-order typed functional choreographies](https://dl.acm.org/doi/10.1145/3498684) diff --git a/examples/bank-2pc/Main.hs b/examples/bank-2pc/Main.hs new file mode 100644 --- /dev/null +++ b/examples/bank-2pc/Main.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Choreography (runChoreography) +import Choreography.Choreo +import Choreography.Location +import Choreography.Network.Http +import Data.List.Split (splitOn) +import Data.Maybe (catMaybes, mapMaybe) +import Data.Proxy +import System.Environment +import Text.Read (readMaybe) + +client :: Proxy "client" +client = Proxy + +coordinator :: Proxy "coordinator" +coordinator = Proxy + +alice :: Proxy "alice" +alice = Proxy + +bob :: Proxy "bob" +bob = Proxy + +type State = (Int @ "alice", Int @ "bob") + +type Action = (String, Int) + +type Transaction = [Action] + +-- | `validate` checks if a transaction can be executed while keeping balance >= 0 +-- returns if the transaction satisfies the property and the balance after the transaction +validate :: String -> Int -> Transaction -> (Bool, Int) +validate name balance tx = foldl (\(valid, i) (_, amount) -> (let next = i + amount in (valid && next >= 0, next))) (True, balance) actions + where + actions = filter (\(n, _) -> n == name) tx + +-- | `parse` converts the user input into a transaction +parse :: String -> Transaction +parse s = tx + where + t = splitOn ";" s + f :: String -> Maybe Action + f l = do + [target, amountStr] <- return $ words l + amount <- readMaybe amountStr :: Maybe Int + target' <- if target == "alice" || target == "bob" then Just target else Nothing + return (target', amount) + tx = mapMaybe f t + +-- | `handleTransaction` is a choreography that handles a transaction. +-- Given the current state and a transaction, it will first ask alice and bob to vote, +-- then it will decide whether to commit the transaction or not. +-- If the transaction is committed, it will update the state. +-- Otherwise, it will keep the state unchanged. +handleTransaction :: State -> Transaction @ "coordinator" -> Choreo IO (Bool @ "coordinator", State) +handleTransaction (aliceBalance, bobBalance) tx = do + -- Voting Phase + txa <- (coordinator, tx) ~> alice + voteAlice <- (alice, \unwrap -> do { return $ fst $ validate "alice" (unwrap aliceBalance) (unwrap txa) }) ~~> coordinator + txb <- (coordinator, tx) ~> bob + voteBob <- (bob, \unwrap -> do { return $ fst $ validate "bob" (unwrap bobBalance) (unwrap txb) }) ~~> coordinator + + -- Check if the transaction can be committed + canCommit <- coordinator `locally` \unwrap -> do return $ unwrap voteAlice && unwrap voteBob + + -- Commit Phase + cond (coordinator, canCommit) \case + True -> do + aliceBalance' <- alice `locally` \unwrap -> do return $ snd $ validate "alice" (unwrap aliceBalance) (unwrap txa) + bobBalance' <- bob `locally` \unwrap -> do return $ snd $ validate "bob" (unwrap bobBalance) (unwrap txb) + return (canCommit, (aliceBalance', bobBalance')) + False -> do + return (canCommit, (aliceBalance, bobBalance)) + +-- | `bank` loops forever and handles transactions. +bank :: State -> Choreo IO () +bank state = do + client `locally` \_ -> do + putStrLn "Command? (alice|bob {amount};)+" + tx <- (client, \_ -> do { parse <$> getLine }) ~~> coordinator + (committed, state') <- handleTransaction state tx + committed' <- (coordinator, committed) ~> client + client `locally` \unwrap -> do + putStrLn if unwrap committed' then "Committed" else "Not committed" + alice `locally` \unwrap -> do putStrLn ("Alice's balance: " ++ show (unwrap (fst state'))) + bob `locally` \unwrap -> do putStrLn ("Bob's balance: " ++ show (unwrap (snd state'))) + bank state' -- repeat + return () + +-- | `startBank` is a choreography that initializes the states and starts the bank application. +startBank :: Choreo IO () +startBank = do + aliceBalance <- alice `locally` \_ -> do return 0 + bobBalance <- bob `locally` \_ -> do return 0 + bank (aliceBalance, bobBalance) + +main :: IO () +main = do + runChoreo startBank diff --git a/examples/bookseller-0-network/Main.hs b/examples/bookseller-0-network/Main.hs new file mode 100644 --- /dev/null +++ b/examples/bookseller-0-network/Main.hs @@ -0,0 +1,55 @@ +module Main where + +import Choreography.Network +import Choreography.Network.Http +import Data.Time +import System.Environment + +buyer :: Network IO () +buyer = do + run $ putStrLn "Enter the title of the book to buy:" + title <- run getLine + send title "seller" + price <- recv "seller" + if price < budget + then do + send True "seller" + (deliveryDate :: Day) <- recv "seller" + run $ putStrLn ("The book will be delivered on " ++ (show deliveryDate)) + else do + send False "seller" + run $ putStrLn "The book's price is out of the budget" + +seller :: Network IO () +seller = do + title <- recv "buyer" + send (priceOf title) "buyer" + decision <- recv "buyer" + if decision + then do + send (deliveryDateOf title) "buyer" + else do + return () + +budget :: Int +budget = 100 + +priceOf :: String -> Int +priceOf "Types and Programming Languages" = 80 +priceOf "Homotopy Type Theory" = 120 + +deliveryDateOf :: String -> Day +deliveryDateOf "Types and Programming Languages" = fromGregorian 2023 12 19 +deliveryDateOf "Homotopy Type Theory" = fromGregorian 2023 09 18 + +main :: IO () +main = do + [loc] <- getArgs + case loc of + "buyer" -> runNetwork cfg "buyer" buyer + "seller" -> runNetwork cfg "seller" seller + return () + where + cfg = mkHttpConfig [ ("buyer", ("localhost", 4242)) + , ("seller", ("localhost", 4343)) + ] diff --git a/examples/bookseller-1-simple/Main.hs b/examples/bookseller-1-simple/Main.hs new file mode 100644 --- /dev/null +++ b/examples/bookseller-1-simple/Main.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} + +module Main where + +import Choreography +import Data.Proxy +import Data.Time +import System.Environment + +buyer :: Proxy "buyer" +buyer = Proxy + +seller :: Proxy "seller" +seller = Proxy + +-- | `bookseller` is a choreography that implements the bookseller protocol. +bookseller :: Choreo IO (Maybe Day @ "buyer") +bookseller = do + -- the buyer node prompts the user to enter the title of the book to buy + title <- + buyer `locally` \_ -> do + putStrLn "Enter the title of the book to buy" + getLine + -- the buyer sends the title to the seller + title' <- (buyer, title) ~> seller + + -- the seller checks the price of the book + price <- seller `locally` \un -> return $ priceOf (un title') + -- the seller sends back the price of the book to the buyer + price' <- (seller, price) ~> buyer + + -- the buyer decides whether to buy the book or not + decision <- buyer `locally` \un -> return $ (un price') < budget + + -- if the buyer decides to buy the book, the seller sends the delivery date to the buyer + cond (buyer, decision) \case + True -> do + deliveryDate <- seller `locally` \un -> return $ deliveryDateOf (un title') + deliveryDate' <- (seller, deliveryDate) ~> buyer + + buyer `locally` \un -> do + putStrLn $ "The book will be delivered on " ++ show (un deliveryDate') + return $ Just (un deliveryDate') + + False -> do + buyer `locally` \_ -> do + putStrLn "The book's price is out of the budget" + return Nothing + +-- `bookseller'` is a simplified version of `bookseller` that utilizes `~~>` +bookseller' :: Choreo IO (Maybe Day @ "buyer") +bookseller' = do + title <- (buyer, \_ -> do + putStrLn "Enter the title of the book to buy" + getLine + ) + ~~> seller + + price <- (seller, \un -> return $ priceOf (un title)) ~~> buyer + + cond' (buyer, \un -> return $ (un price) < budget) \case + True -> do + deliveryDate <- (seller, \un -> return $ deliveryDateOf (un title)) ~~> buyer + + buyer `locally` \un -> do + putStrLn $ "The book will be delivered on " ++ show (un deliveryDate) + return $ Just (un deliveryDate) + + False -> do + buyer `locally` \_ -> do + putStrLn "The book's price is out of the budget" + return Nothing + +budget :: Int +budget = 100 + +priceOf :: String -> Int +priceOf "Types and Programming Languages" = 80 +priceOf "Homotopy Type Theory" = 120 + +deliveryDateOf :: String -> Day +deliveryDateOf "Types and Programming Languages" = fromGregorian 2022 12 19 +deliveryDateOf "Homotopy Type Theory" = fromGregorian 2023 01 01 + +main :: IO () +main = do + [loc] <- getArgs + case loc of + "buyer" -> runChoreography cfg bookseller' "buyer" + "seller" -> runChoreography cfg bookseller' "seller" + return () + where + cfg = mkHttpConfig [ ("buyer", ("localhost", 4242)) + , ("seller", ("localhost", 4343)) + ] diff --git a/examples/bookseller-2-higher-order/Main.hs b/examples/bookseller-2-higher-order/Main.hs new file mode 100644 --- /dev/null +++ b/examples/bookseller-2-higher-order/Main.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} + +module Main where + +import Choreography +import Data.Proxy +import Data.Time +import System.Environment + +buyer :: Proxy "buyer" +buyer = Proxy + +seller :: Proxy "seller" +seller = Proxy + +buyer2 :: Proxy "buyer2" +buyer2 = Proxy + +-- | `bookseller` is a choreography that implements the bookseller protocol. +-- This version takes a choreography `mkDecision` that implements the decision making process. +bookseller :: (Int @ "buyer" -> Choreo IO (Bool @ "buyer")) -> Choreo IO (Maybe Day @ "buyer") +bookseller mkDecision = do + -- the buyer reads the title of the book and sends it to the seller + title <- (buyer, \_ -> do + putStrLn "Enter the title of the book to buy" + getLine + ) + ~~> seller + + -- the seller checks the price of the book and sends it to the buyer + price <- (seller, \un -> return $ priceOf (un title)) ~~> buyer + + -- the buyer makes a decision using the `mkDecision` choreography + decision <- mkDecision price + + -- if the buyer decides to buy the book, the seller sends the delivery date to the buyer + cond (buyer, decision) \case + True -> do + deliveryDate <- (seller, \un -> return $ deliveryDateOf (un title)) ~~> buyer + + buyer `locally` \un -> do + putStrLn $ "The book will be delivered on " ++ show (un deliveryDate) + return $ Just (un deliveryDate) + + False -> do + buyer `locally` \_ -> do + putStrLn "The book's price is out of the budget" + return Nothing + +-- | `mkDecision1` checks if buyer's budget is greater than the price of the book +mkDecision1 :: Int @ "buyer" -> Choreo IO (Bool @ "buyer") +mkDecision1 price = do + buyer `locally` \un -> return $ un price < budget + +-- | `mkDecision2` asks buyer2 how much they're willing to contribute and checks +-- if the buyer's budget is greater than the price of the book minus buyer2's contribution +mkDecision2 :: Int @ "buyer" -> Choreo IO (Bool @ "buyer") +mkDecision2 price = do + contrib <- (buyer2, \_ -> do + putStrLn "How much you're willing to contribute?" + read <$> getLine + ) + ~~> buyer + buyer `locally` \un -> return $ un price - un contrib <= budget + +budget :: Int +budget = 100 + +priceOf :: String -> Int +priceOf "Types and Programming Languages" = 80 +priceOf "Homotopy Type Theory" = 120 + +deliveryDateOf :: String -> Day +deliveryDateOf "Types and Programming Languages" = fromGregorian 2022 12 19 +deliveryDateOf "Homotopy Type Theory" = fromGregorian 2023 01 01 + +main :: IO () +main = do + [loc] <- getArgs + case loc of + "buyer" -> runChoreography cfg choreo "buyer" + "seller" -> runChoreography cfg choreo "seller" + "buyer2" -> runChoreography cfg choreo "buyer2" + return () + where + choreo = bookseller mkDecision2 + + cfg = mkHttpConfig [ ("buyer", ("localhost", 4242)) + , ("seller", ("localhost", 4343)) + , ("buyer2", ("localhost", 4444)) + ] diff --git a/examples/bookseller-3-loc-poly/Main.hs b/examples/bookseller-3-loc-poly/Main.hs new file mode 100644 --- /dev/null +++ b/examples/bookseller-3-loc-poly/Main.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} + +module Main where + +import Choreography +import Data.Proxy +import Data.Time +import GHC.TypeLits +import System.Environment + +buyer :: Proxy "buyer" +buyer = Proxy + +seller :: Proxy "seller" +seller = Proxy + +-- | `bookseller` is a choreography that implements the bookseller protocol. +-- This version takes the name of the buyer as a parameter (`someBuyer`). +bookseller :: KnownSymbol a => Proxy a -> Choreo IO (Maybe Day @ a) +bookseller someBuyer = do + -- the buyer reads the title of the book and sends it to the seller + title <- (buyer, \_ -> do + putStrLn "Enter the title of the book to buy" + getLine + ) + ~~> seller + + -- the seller checks the price of the book and sends it to the buyer + price <- (seller, \un -> return $ priceOf (un title)) ~~> someBuyer + + cond' (someBuyer, \un -> return $ (un price) < budget) \case + True -> do + deliveryDate <- (seller, \un -> return $ deliveryDateOf (un title)) ~~> someBuyer + + someBuyer `locally` \un -> do + putStrLn $ "The book will be delivered on " ++ show (un deliveryDate) + return $ Just (un deliveryDate) + + False -> do + someBuyer `locally` \_ -> do + putStrLn "The book's price is out of the budget" + return Nothing + +budget :: Int +budget = 100 + +priceOf :: String -> Int +priceOf "Types and Programming Languages" = 80 +priceOf "Homotopy Type Theory" = 120 + +deliveryDateOf :: String -> Day +deliveryDateOf "Types and Programming Languages" = fromGregorian 2022 12 19 +deliveryDateOf "Homotopy Type Theory" = fromGregorian 2023 01 01 + +main :: IO () +main = do + [loc] <- getArgs + case loc of + "buyer" -> runChoreography cfg choreo "buyer" + "seller" -> runChoreography cfg choreo "seller" + return () + where + choreo = bookseller buyer + + cfg = mkHttpConfig [ ("buyer", ("localhost", 4242)) + , ("seller", ("localhost", 4343)) + ] diff --git a/examples/diffiehellman/Main.hs b/examples/diffiehellman/Main.hs new file mode 100644 --- /dev/null +++ b/examples/diffiehellman/Main.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} + +module Main where + +import Choreography (mkHttpConfig, runChoreography) +import Choreography.Choreo +import Choreography.Location +import Data.Proxy +import Data.Time +import System.Environment +import System.Random + +-- helper functions around prime number +-- https://nulldereference.wordpress.com/2012/02/04/generating-prime-numbers-with-haskell/ +divisors :: Integer -> [Integer] +divisors 1 = [1] +divisors x = 1 : [y | y <- [2 .. (x `div` 2)], x `mod` y == 0] ++ [x] + +isPrime :: Integer -> Bool +isPrime x = divisors x == [1, x] + +primeNums :: [Integer] +primeNums = [x | x <- [2 ..], isPrime x] + +-- set up proxies +alice :: Proxy "alice" +alice = Proxy + +bob :: Proxy "bob" +bob = Proxy + +diffieHellman :: Choreo IO (Integer @ "alice", Integer @ "bob") +diffieHellman = do + -- wait for alice to initiate the process + alice `locally` \unwrap -> do + putStrLn "enter to start key exchange..." + getLine + bob `locally` \unwrap -> do + putStrLn "waiting for alice to initiate key exchange" + + -- alice picks p and g and sends them to bob + pa <- + alice `locally` \unwrap -> do + x <- randomRIO (200, 1000 :: Int) + return $ primeNums !! x + pb <- (alice, pa) ~> bob + ga <- alice `locally` \unwrap -> do randomRIO (10, unwrap pa) + gb <- (alice, ga) ~> bob + + -- alice and bob select secrets + a <- alice `locally` \unwrap -> do randomRIO (200, 1000 :: Integer) + b <- bob `locally` \unwrap -> do randomRIO (200, 1000 :: Integer) + + -- alice and bob computes numbers that they exchange + a' <- alice `locally` \unwrap -> do return $ unwrap ga ^ unwrap a `mod` unwrap pa + b' <- bob `locally` \unwrap -> do return $ unwrap gb ^ unwrap b `mod` unwrap pb + + -- exchange numbers + a'' <- (alice, a') ~> bob + b'' <- (bob, b') ~> alice + + -- compute shared key + s1 <- + alice `locally` \unwrap -> + let s = unwrap b'' ^ unwrap a `mod` unwrap pa + in do + putStrLn ("alice's shared key: " ++ show s) + return s + s2 <- + bob `locally` \unwrap -> + let s = unwrap a'' ^ unwrap b `mod` unwrap pb + in do + putStrLn ("bob's shared key: " ++ show s) + return s + return (s1, s2) + +main :: IO () +main = do + [loc] <- getArgs + x <- case loc of + "alice" -> runChoreography config diffieHellman "alice" + "bob" -> runChoreography config diffieHellman "bob" + return () + where + config = + mkHttpConfig + [ ("alice", ("localhost", 5000)), + ("bob", ("localhost", 5001)) + ] diff --git a/examples/karatsuba/Main.hs b/examples/karatsuba/Main.hs new file mode 100644 --- /dev/null +++ b/examples/karatsuba/Main.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} + +module Main where + +import Choreography (runChoreography) +import Choreography.Choreo +import Choreography.Location +import Choreography.Network.Local +import Control.Concurrent.Async (async, mapConcurrently_, wait) +import Data.Proxy +import GHC.TypeLits (KnownSymbol) +import System.Environment + +primary :: Proxy "primary" +primary = Proxy + +worker1 :: Proxy "worker1" +worker1 = Proxy + +worker2 :: Proxy "worker2" +worker2 = Proxy + +data KaratsubaNums = KaratsubaNums + { splitter :: Integer, + h1 :: Integer, + h2 :: Integer, + l1 :: Integer, + l2 :: Integer + } + +karatsuba :: + (KnownSymbol a, KnownSymbol b, KnownSymbol c) => + Proxy a -> + Proxy b -> + Proxy c -> + (Integer @ a) -> + (Integer @ a) -> + Choreo IO (Integer @ a) +karatsuba a b c n1 n2 = do + done <- a `locally` \unwrap -> return $ unwrap n1 < 10 || unwrap n2 < 10 + cond + (a, done) + \case + True -> do + a `locally` \unwrap -> return $ unwrap n1 * unwrap n2 + False -> do + x <- a `locally` \unwrap -> return $ f (unwrap n1) (unwrap n2) + l1' <- (a, \unwrap -> return $ l1 (unwrap x)) ~~> b + l2' <- (a, \unwrap -> return $ l2 (unwrap x)) ~~> b + h1' <- (a, \unwrap -> return $ h1 (unwrap x)) ~~> c + h2' <- (a, \unwrap -> return $ h2 (unwrap x)) ~~> c + z0' <- karatsuba b c a l1' l2' + z0 <- (b, z0') ~> a + z2' <- karatsuba c a b h1' h2' + z2 <- (c, z2') ~> a + s1 <- a `locally` \unwrap -> return $ l1 (unwrap x) + h1 (unwrap x) + s2 <- a `locally` \unwrap -> return $ l2 (unwrap x) + h2 (unwrap x) + z1' <- karatsuba a b c s1 s2 + z1 <- a `locally` \unwrap -> return $ unwrap z1' - unwrap z2 - unwrap z0 + a `locally` \unwrap -> return let s = splitter (unwrap x) in (unwrap z2 * s * s) + (unwrap z1 * s) + unwrap z0 + where + f n1 n2 = KaratsubaNums {splitter = splitter, h1 = h1, l1 = l1, h2 = h2, l2 = l2} + where + log10 :: Integer -> Double + log10 = logBase 10 . fromIntegral + m = max (log10 n1) (log10 n2) + 1 + m2 = floor (m / 2) + splitter = 10 ^ m2 + h1 = n1 `div` splitter + l1 = n1 `mod` splitter + h2 = n2 `div` splitter + l2 = n2 `mod` splitter + +mainChoreo :: Integer -> Integer -> Choreo IO () +mainChoreo n1 n2 = do + n1 <- primary `locally` \_ -> return n1 + n2 <- primary `locally` \_ -> return n2 + result <- karatsuba primary worker1 worker2 n1 n2 + primary `locally` \unwrap -> do + print (unwrap result) + return () + return () + +main :: IO () +main = do + [n1, n2] <- map read <$> getArgs + config <- mkLocalConfig locs + mapConcurrently_ (runChoreography config (mainChoreo n1 n2)) locs + return () + where + locs = ["primary", "worker1", "worker2"] diff --git a/examples/kvs-1-simple/Main.hs b/examples/kvs-1-simple/Main.hs new file mode 100644 --- /dev/null +++ b/examples/kvs-1-simple/Main.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Choreography (runChoreography) +import Choreography.Choreo +import Choreography.Location +import Choreography.Network.Http +import Control.Concurrent (threadDelay) +import Control.Monad +import Data.IORef +import Data.Map (Map, (!)) +import Data.Map qualified as Map +import Data.Maybe (fromMaybe, isJust) +import Data.Proxy +import GHC.IORef (IORef (IORef)) +import GHC.TypeLits (KnownSymbol) +import System.Environment + +client :: Proxy "client" +client = Proxy + +server :: Proxy "server" +server = Proxy + +type State = Map String String + +data Request = Put String String | Get String deriving (Show, Read) + +type Response = Maybe String + +-- | `readRequest` reads a request from the terminal. +readRequest :: IO Request +readRequest = do + putStrLn "Command?" + line <- getLine + case parseRequest line of + Just t -> return t + Nothing -> putStrLn "Invalid command" >> readRequest + where + parseRequest :: String -> Maybe Request + parseRequest s = + let l = words s + in case l of + ["GET", k] -> Just (Get k) + ["PUT", k, v] -> Just (Put k v) + _ -> Nothing + +-- | `handleRequest` handle a request and returns the new the state. +handleRequest :: Request -> IORef State -> IO Response +handleRequest request stateRef = case request of + Put key value -> do + modifyIORef stateRef (Map.insert key value) + return (Just value) + Get key -> do + state <- readIORef stateRef + return (Map.lookup key state) + +-- | `kvs` is a choreography that processes a single request located at the client and returns the response. +kvs :: + Request @ "client" -> + IORef State @ "server" -> + Choreo IO (Response @ "client") +kvs request stateRef = do + -- send the request to the server + request' <- (client, request) ~> server + -- the server handles the response and creates a response + response <- + server `locally` \unwrap -> + handleRequest (unwrap request') (unwrap stateRef) + -- send the response back to the client + (server, response) ~> client + +-- | `mainChoreo` is a choreography that serves as the entry point of the program. +-- It initializes the state and loops forever. +mainChoreo :: Choreo IO () +mainChoreo = do + stateRef <- server `locally` \_ -> newIORef (Map.empty :: State) + loop stateRef + where + loop :: IORef State @ "server" -> Choreo IO () + loop stateRef = do + request <- client `locally` \_ -> readRequest + response <- kvs request stateRef + client `locally` \unwrap -> do putStrLn ("> " ++ (show (unwrap response))) + loop stateRef + +main :: IO () +main = do + [loc] <- getArgs + case loc of + "client" -> runChoreography config mainChoreo "client" + "server" -> runChoreography config mainChoreo "server" + return () + where + config = + mkHttpConfig + [ ("client", ("localhost", 3000)), + ("server", ("localhost", 4000)) + ] diff --git a/examples/kvs-2-primary-backup/Main.hs b/examples/kvs-2-primary-backup/Main.hs new file mode 100644 --- /dev/null +++ b/examples/kvs-2-primary-backup/Main.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Choreography (runChoreography) +import Choreography.Choreo +import Choreography.Location +import Choreography.Network.Http +import Control.Concurrent (threadDelay) +import Control.Monad +import Data.IORef +import Data.Map (Map, (!)) +import Data.Map qualified as Map +import Data.Maybe (fromMaybe, isJust) +import Data.Proxy +import GHC.IORef (IORef (IORef)) +import GHC.TypeLits (KnownSymbol) +import System.Environment + +client :: Proxy "client" +client = Proxy + +primary :: Proxy "primary" +primary = Proxy + +backup :: Proxy "backup" +backup = Proxy + +type State = Map String String + +data Request = Put String String | Get String deriving (Show, Read) + +type Response = Maybe String + +-- | `readRequest` reads a request from the terminal. +readRequest :: IO Request +readRequest = do + putStrLn "Command?" + line <- getLine + case parseRequest line of + Just t -> return t + Nothing -> putStrLn "Invalid command" >> readRequest + where + parseRequest :: String -> Maybe Request + parseRequest s = + let l = words s + in case l of + ["GET", k] -> Just (Get k) + ["PUT", k, v] -> Just (Put k v) + _ -> Nothing + +-- | `handleRequest` handle a request and returns the new the state. +handleRequest :: Request -> IORef State -> IO Response +handleRequest request stateRef = case request of + Put key value -> do + modifyIORef stateRef (Map.insert key value) + return (Just value) + Get key -> do + state <- readIORef stateRef + return (Map.lookup key state) + +-- | `kvs` is a choreography that processes a single request located at the client and returns the response. +-- If the request is a `PUT`, it will forward the request to the backup node. +kvs :: + Request @ "client" -> + (IORef State @ "primary", IORef State @ "backup") -> + Choreo IO (Response @ "client") +kvs request (primaryStateRef, backupStateRef) = do + -- send request to the primary node + request' <- (client, request) ~> primary + + -- branch on the request + cond (primary, request') \case + -- if the request is a `PUT`, forward the request to the backup node + Put key value -> do + request'' <- (primary, request') ~> backup + ack <- + backup `locally` \unwrap -> do + handleRequest (unwrap request'') (unwrap backupStateRef) + (backup, ack) ~> primary + return () + _ -> do + return () + + -- process request on the primary node + response <- + primary `locally` \unwrap -> + handleRequest (unwrap request') (unwrap primaryStateRef) + + -- send response to client + (primary, response) ~> client + +-- | `mainChoreo` is a choreography that serves as the entry point of the program. +-- It initializes the state and loops forever. +mainChoreo :: Choreo IO () +mainChoreo = do + primaryStateRef <- primary `locally` \_ -> newIORef (Map.empty :: State) + backupStateRef <- backup `locally` \_ -> newIORef (Map.empty :: State) + loop (primaryStateRef, backupStateRef) + where + loop :: (IORef State @ "primary", IORef State @ "backup") -> Choreo IO () + loop stateRefs = do + request <- client `locally` \_ -> readRequest + response <- kvs request stateRefs + client `locally` \unwrap -> do putStrLn ("> " ++ show (unwrap response)) + loop stateRefs + +main :: IO () +main = do + [loc] <- getArgs + case loc of + "client" -> runChoreography config mainChoreo "client" + "primary" -> runChoreography config mainChoreo "primary" + "backup" -> runChoreography config mainChoreo "backup" + return () + where + config = + mkHttpConfig + [ ("client", ("localhost", 3000)), + ("primary", ("localhost", 4000)), + ("backup", ("localhost", 5000)) + ] diff --git a/examples/kvs-3-higher-order/Main.hs b/examples/kvs-3-higher-order/Main.hs new file mode 100644 --- /dev/null +++ b/examples/kvs-3-higher-order/Main.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Choreography (runChoreography) +import Choreography.Choreo +import Choreography.Location +import Choreography.Network.Http +import Control.Concurrent (threadDelay) +import Control.Monad +import Data.IORef +import Data.Map (Map, (!)) +import Data.Map qualified as Map +import Data.Maybe (fromMaybe, isJust) +import Data.Proxy +import GHC.IORef (IORef (IORef)) +import GHC.TypeLits (KnownSymbol) +import System.Environment + +client :: Proxy "client" +client = Proxy + +primary :: Proxy "primary" +primary = Proxy + +backup :: Proxy "backup" +backup = Proxy + +type State = Map String String + +data Request = Put String String | Get String deriving (Show, Read) + +type Response = Maybe String + +-- | `readRequest` reads a request from the terminal. +readRequest :: IO Request +readRequest = do + putStrLn "Command?" + line <- getLine + case parseRequest line of + Just t -> return t + Nothing -> putStrLn "Invalid command" >> readRequest + where + parseRequest :: String -> Maybe Request + parseRequest s = + let l = words s + in case l of + ["GET", k] -> Just (Get k) + ["PUT", k, v] -> Just (Put k v) + _ -> Nothing + +-- | `handleRequest` handle a request and returns the new the state. +handleRequest :: Request -> IORef State -> IO Response +handleRequest request stateRef = case request of + Put key value -> do + modifyIORef stateRef (Map.insert key value) + return (Just value) + Get key -> do + state <- readIORef stateRef + return (Map.lookup key state) + +-- | ReplicationStrategy specifies how a request should be handled on possibly replicated servers +-- `a` is a type that represent states across locations +type ReplicationStrategy a = + Request @ "primary" -> a -> Choreo IO (Response @ "primary") + +-- | `nullReplicationStrategy` is a replication strategy that does not replicate the state. +nullReplicationStrategy :: ReplicationStrategy (IORef State @ "primary") +nullReplicationStrategy request stateRef = do + primary `locally` \unwrap -> + handleRequest (unwrap request) (unwrap stateRef) + +-- | `primaryBackupReplicationStrategy` is a replication strategy that replicates the state to a backup server. +primaryBackupReplicationStrategy :: + ReplicationStrategy (IORef State @ "primary", IORef State @ "backup") +primaryBackupReplicationStrategy request (primaryStateRef, backupStateRef) = do + -- relay request to backup if it is mutating (= PUT) + cond (primary, request) \case + Put _ _ -> do + request' <- (primary, request) ~> backup + ( backup, + \unwrap -> + handleRequest (unwrap request') (unwrap backupStateRef) + ) + ~~> primary + return () + _ -> do + return () + + -- process request on primary + primary `locally` \unwrap -> + handleRequest (unwrap request) (unwrap primaryStateRef) + +-- | `kvs` is a choreography that processes a single request at the client and returns the response. +-- It uses the provided replication strategy to handle the request. +kvs :: + forall a. + Request @ "client" -> + a -> + ReplicationStrategy a -> + Choreo IO (Response @ "client") +kvs request stateRefs replicationStrategy = do + request' <- (client, request) ~> primary + + -- call the provided replication strategy + response <- replicationStrategy request' stateRefs + + -- send response to client + (primary, response) ~> client + +-- | `nullReplicationChoreo` is a choreography that uses `nullReplicationStrategy`. +nullReplicationChoreo :: Choreo IO () +nullReplicationChoreo = do + stateRef <- primary `locally` \_ -> newIORef (Map.empty :: State) + loop stateRef + where + loop :: IORef State @ "primary" -> Choreo IO () + loop stateRef = do + request <- client `locally` \_ -> readRequest + response <- kvs request stateRef nullReplicationStrategy + client `locally` \unwrap -> do putStrLn (show (unwrap response)) + loop stateRef + +-- | `primaryBackupChoreo` is a choreography that uses `primaryBackupReplicationStrategy`. +primaryBackupChoreo :: Choreo IO () +primaryBackupChoreo = do + primaryStateRef <- primary `locally` \_ -> newIORef (Map.empty :: State) + backupStateRef <- backup `locally` \_ -> newIORef (Map.empty :: State) + loop (primaryStateRef, backupStateRef) + where + loop :: (IORef State @ "primary", IORef State @ "backup") -> Choreo IO () + loop stateRefs = do + request <- client `locally` \_ -> readRequest + response <- kvs request stateRefs primaryBackupReplicationStrategy + client `locally` \unwrap -> do putStrLn ("> " ++ show (unwrap response)) + loop stateRefs + +main :: IO () +main = do + [loc] <- getArgs + case loc of + "client" -> runChoreography config mainChoreo "client" + "primary" -> runChoreography config mainChoreo "primary" + "backup" -> runChoreography config mainChoreo "backup" + return () + where + mainChoreo = primaryBackupChoreo -- or `nullReplicationChoreo` + config = + mkHttpConfig + [ ("client", ("localhost", 3000)), + ("primary", ("localhost", 4000)), + ("backup", ("localhost", 5000)) + ] diff --git a/examples/kvs-4-loc-poly/Main.hs b/examples/kvs-4-loc-poly/Main.hs new file mode 100644 --- /dev/null +++ b/examples/kvs-4-loc-poly/Main.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Choreography (runChoreography) +import Choreography.Choreo +import Choreography.Location +import Choreography.Network.Http +import Control.Concurrent (threadDelay) +import Control.Monad +import Data.IORef +import Data.Map (Map, (!)) +import Data.Map qualified as Map +import Data.Maybe (fromMaybe, isJust) +import Data.Proxy +import GHC.IORef (IORef (IORef)) +import GHC.TypeLits (KnownSymbol) +import System.Environment + +client :: Proxy "client" +client = Proxy + +primary :: Proxy "primary" +primary = Proxy + +backup1 :: Proxy "backup1" +backup1 = Proxy + +backup2 :: Proxy "backup2" +backup2 = Proxy + +type State = Map String String + +data Request = Put String String | Get String deriving (Show, Read) + +type Response = Maybe String + +-- | `readRequest` reads a request from the terminal. +readRequest :: IO Request +readRequest = do + putStrLn "Command?" + line <- getLine + case parseRequest line of + Just t -> return t + Nothing -> putStrLn "Invalid command" >> readRequest + where + parseRequest :: String -> Maybe Request + parseRequest s = + let l = words s + in case l of + ["GET", k] -> Just (Get k) + ["PUT", k, v] -> Just (Put k v) + _ -> Nothing + +-- | `handleRequest` handle a request and returns the new the state. +handleRequest :: Request -> IORef State -> IO Response +handleRequest request stateRef = case request of + Put key value -> do + modifyIORef stateRef (Map.insert key value) + return (Just value) + Get key -> do + state <- readIORef stateRef + return (Map.lookup key state) + +-- | ReplicationStrategy specifies how a request should be handled on possibly replicated servers +-- `a` is a type that represent states across locations +type ReplicationStrategy a = Request @ "primary" -> a -> Choreo IO (Response @ "primary") + +-- | `nullReplicationStrategy` is a replication strategy that does not replicate the state. +nullReplicationStrategy :: ReplicationStrategy (IORef State @ "primary") +nullReplicationStrategy request stateRef = do + primary `locally` \unwrap -> case unwrap request of + Put key value -> do + modifyIORef (unwrap stateRef) (Map.insert key value) + return (Just value) + Get key -> do + state <- readIORef (unwrap stateRef) + return (Map.lookup key state) + +-- | `doBackup` relays a mutating request to a backup location. +doBackup :: + KnownSymbol a => + KnownSymbol b => + Proxy a -> + Proxy b -> + Request @ a -> + IORef State @ b -> + Choreo IO () +doBackup locA locB request stateRef = do + cond (locA, request) \case + Put _ _ -> do + request' <- (locA, request) ~> locB + (locB, \unwrap -> handleRequest (unwrap request') (unwrap stateRef)) + ~~> locA + return () + _ -> do + return () + +-- | `primaryBackupReplicationStrategy` is a replication strategy that replicates the state to a backup server. +primaryBackupReplicationStrategy :: ReplicationStrategy (IORef State @ "primary", IORef State @ "backup1") +primaryBackupReplicationStrategy request (primaryStateRef, backupStateRef) = do + -- relay request to backup if it is mutating (= PUT) + doBackup primary backup1 request backupStateRef + + -- process request on primary + primary `locally` \unwrap -> handleRequest (unwrap request) (unwrap primaryStateRef) + +-- | `doubleBackupReplicationStrategy` is a replication strategy that replicates the state to two backup servers. +doubleBackupReplicationStrategy :: + ReplicationStrategy + (IORef State @ "primary", IORef State @ "backup1", IORef State @ "backup2") +doubleBackupReplicationStrategy + request + (primaryStateRef, backup1StateRef, backup2StateRef) = do + -- relay to two backup locations + doBackup primary backup1 request backup1StateRef + doBackup primary backup2 request backup2StateRef + + -- process request on primary + primary `locally` \unwrap -> + handleRequest (unwrap request) (unwrap primaryStateRef) + +-- | `kvs` is a choreography that processes a single request at the client and returns the response. +-- It uses the provided replication strategy to handle the request. +kvs :: Request @ "client" -> a -> ReplicationStrategy a -> Choreo IO (Response @ "client") +kvs request stateRefs replicationStrategy = do + request' <- (client, request) ~> primary + + -- call the provided replication strategy + response <- replicationStrategy request' stateRefs + + -- send response to client + (primary, response) ~> client + +-- | `nullReplicationChoreo` is a choreography that uses `nullReplicationStrategy`. +nullReplicationChoreo :: Choreo IO () +nullReplicationChoreo = do + stateRef <- primary `locally` \_ -> newIORef (Map.empty :: State) + loop stateRef + where + loop :: IORef State @ "primary" -> Choreo IO () + loop stateRef = do + request <- client `locally` \_ -> readRequest + response <- kvs request stateRef nullReplicationStrategy + client `locally` \unwrap -> do putStrLn (show (unwrap response)) + loop stateRef + +-- | `primaryBackupChoreo` is a choreography that uses `primaryBackupReplicationStrategy`. +primaryBackupChoreo :: Choreo IO () +primaryBackupChoreo = do + primaryStateRef <- primary `locally` \_ -> newIORef (Map.empty :: State) + backupStateRef <- backup1 `locally` \_ -> newIORef (Map.empty :: State) + loop (primaryStateRef, backupStateRef) + where + loop :: (IORef State @ "primary", IORef State @ "backup1") -> Choreo IO () + loop stateRefs = do + request <- client `locally` \_ -> readRequest + response <- kvs request stateRefs primaryBackupReplicationStrategy + client `locally` \unwrap -> do putStrLn (show (unwrap response)) + loop stateRefs + +-- | `doubleBackupChoreo` is a choreography that uses `doubleBackupReplicationStrategy`. +doubleBackupChoreo :: Choreo IO () +doubleBackupChoreo = do + primaryStateRef <- primary `locally` \_ -> newIORef (Map.empty :: State) + backup1StateRef <- backup1 `locally` \_ -> newIORef (Map.empty :: State) + backup2StateRef <- backup2 `locally` \_ -> newIORef (Map.empty :: State) + loop (primaryStateRef, backup1StateRef, backup2StateRef) + where + loop :: (IORef State @ "primary", IORef State @ "backup1", IORef State @ "backup2") -> Choreo IO () + loop stateRefs = do + request <- client `locally` \_ -> readRequest + response <- kvs request stateRefs doubleBackupReplicationStrategy + client `locally` \unwrap -> do putStrLn ("> " ++ show (unwrap response)) + loop stateRefs + +main :: IO () +main = do + [loc] <- getArgs + case loc of + "client" -> runChoreography config primaryBackupChoreo "client" + "primary" -> runChoreography config primaryBackupChoreo "primary" + "backup1" -> runChoreography config primaryBackupChoreo "backup1" + "backup2" -> runChoreography config primaryBackupChoreo "backup2" + return () + where + config = + mkHttpConfig + [ ("client", ("localhost", 3000)), + ("primary", ("localhost", 4000)), + ("backup1", ("localhost", 5000)), + ("backup2", ("localhost", 6000)) + ] diff --git a/examples/mergesort/Main.hs b/examples/mergesort/Main.hs new file mode 100644 --- /dev/null +++ b/examples/mergesort/Main.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} + +module Main where + +import Choreography (runChoreography) +import Choreography.Choreo +import Choreography.Location +import Choreography.Network.Http +import Data.Proxy +import Data.Time +import GHC.TypeLits (KnownSymbol) +import System.Environment + +divide :: [a] -> ([a], [a]) +divide xs = splitAt lhx xs + where + lhx = length xs `div` 2 + +primary :: Proxy "primary" +primary = Proxy + +worker1 :: Proxy "worker1" +worker1 = Proxy + +worker2 :: Proxy "worker2" +worker2 = Proxy + +sort :: + KnownSymbol a => + Proxy a -> + KnownSymbol b => + Proxy b -> + KnownSymbol c => + Proxy c -> + ([Int] @ a) -> + Choreo IO ([Int] @ a) +sort a b c lst = do + condition <- a `locally` \unwrap -> do return $ length (unwrap lst) > 1 + cond (a, condition) \case + True -> do + pivot <- a `locally` \unwrap -> do return $ length (unwrap lst) `div` 2 + divided <- a `locally` \unwrap -> do return $ divide (unwrap lst) + l <- a `locally` \unwrap -> do return $ fst (unwrap divided) + r <- a `locally` \unwrap -> do return $ snd (unwrap divided) + l' <- (a, l) ~> b + r' <- (a, r) ~> c + ls' <- sort b c a l' + rs' <- sort c a b r' + merge a b c ls' rs' + False -> do + return lst + +merge :: + KnownSymbol a => + Proxy a -> + KnownSymbol b => + Proxy b -> + KnownSymbol c => + Proxy c -> + [Int] @ b -> + [Int] @ c -> + Choreo IO ([Int] @ a) +merge a b c lhs rhs = do + lhsHasElements <- b `locally` \unwrap -> do return $ not (null (unwrap lhs)) + cond (b, lhsHasElements) \case + True -> do + rhsHasElements <- c `locally` \unwrap -> do return $ not (null (unwrap rhs)) + cond (c, rhsHasElements) \case + True -> do + rhsHeadAtC <- c `locally` \unwrap -> do return $ head (unwrap rhs) + rhsHeadAtB <- (c, rhsHeadAtC) ~> b + takeLhs <- b `locally` \unwrap -> do return $ head (unwrap lhs) <= unwrap rhsHeadAtB + cond (b, takeLhs) \case + True -> do + -- take (head lhs) and merge the rest + lhs' <- b `locally` \unwrap -> do return $ tail (unwrap lhs) + merged <- merge a b c lhs' rhs + lhsHeadAtB <- b `locally` \unwrap -> do return $ head (unwrap lhs) + lhsHeadAtA <- (b, lhsHeadAtB) ~> a + a `locally` \unwrap -> do return $ unwrap lhsHeadAtA : unwrap merged + False -> do + -- take (head rhs) and merge the rest + rhs' <- c `locally` \unwrap -> do return $ tail (unwrap rhs) + merged <- merge a b c lhs rhs' + rhsHeadAtC <- c `locally` \unwrap -> do return $ head (unwrap rhs) + rhsHeadAtA <- (c, rhsHeadAtC) ~> a + a `locally` \unwrap -> do return $ unwrap rhsHeadAtA : unwrap merged + False -> do + (b, lhs) ~> a + False -> do + (c, rhs) ~> a + +mainChoreo :: Choreo IO () +mainChoreo = do + lst <- primary `locally` \unwrap -> do return [1, 6, 5, 3, 4, 2, 7, 8] + sorted <- sort primary worker1 worker2 lst + primary `locally` \unwrap -> do + print (unwrap sorted) + return () + return () + +main :: IO () +main = do + [loc] <- getArgs + case loc of + "primary" -> runChoreography config mainChoreo "primary" + "worker1" -> runChoreography config mainChoreo "worker1" + "worker2" -> runChoreography config mainChoreo "worker2" + return () + where + config = + mkHttpConfig + [ ("primary", ("localhost", 3000)), + ("worker1", ("localhost", 4000)), + ("worker2", ("localhost", 5000)) + ] diff --git a/examples/playground/Main.hs b/examples/playground/Main.hs new file mode 100644 --- /dev/null +++ b/examples/playground/Main.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} + +module Main where + +import Choreography +import Control.Monad +import Data.Proxy +import System.Environment + +-- Step 1: Defining locations +alice :: Proxy "alice" +alice = Proxy + +-- Step 2: Writing a choreography +choreography :: Choreo IO (() @ "alice") +choreography = do + alice `locally` \_ -> putStrLn "Hello, world!" + +-- Step 3: Projecting and running the chreography +main :: IO () +main = do + args <- getArgs + case args of + [loc] -> void $ runChoreography cfg choreography loc + _ -> error "wrong usage: must provide exactly one location" + where + -- Step 4: Mapping locations to HTTP ports + cfg = mkHttpConfig [ ("alice", ("localhost", 4242)) + ] diff --git a/examples/quicksort/Main.hs b/examples/quicksort/Main.hs new file mode 100644 --- /dev/null +++ b/examples/quicksort/Main.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} + +module Main where + +import Choreography (runChoreography) +import Choreography.Choreo +import Choreography.Location +import Choreography.Network.Local +import Control.Concurrent.Async (async, mapConcurrently_, wait) +import Data.Proxy +import Data.Time +import GHC.TypeLits (KnownSymbol) +import System.Environment + +primary :: Proxy "primary" +primary = Proxy + +worker1 :: Proxy "worker1" +worker1 = Proxy + +worker2 :: Proxy "worker2" +worker2 = Proxy + +quicksort :: (KnownSymbol a, KnownSymbol b, KnownSymbol c) => Proxy a -> Proxy b -> Proxy c -> [Int] @ a -> Choreo IO ([Int] @ a) +quicksort a b c lst = do + isEmpty <- a `locally` \unwrap -> pure (null (unwrap lst)) + cond (a, isEmpty) \case + True -> do + a `locally` \_ -> pure [] + False -> do + smaller <- (a, \unwrap -> let x : xs = unwrap lst in pure [i | i <- xs, i <= x]) ~~> b + smaller' <- quicksort b c a smaller + smaller'' <- (b, smaller') ~> a + bigger <- (a, \unwrap -> let x : xs = unwrap lst in pure [i | i <- xs, i > x]) ~~> c + bigger' <- quicksort c a b bigger + bigger'' <- (c, bigger') ~> a + a `locally` \unwrap -> pure $ unwrap smaller'' ++ [head (unwrap lst)] ++ unwrap bigger'' + +mainChoreo :: Choreo IO () +mainChoreo = do + lst <- primary `locally` \unwrap -> do return [1, 6, 5, 3, 4, 2, 7, 8] + sorted <- quicksort primary worker1 worker2 lst + primary `locally` \unwrap -> do + print (unwrap sorted) + return () + return () + +main :: IO () +main = do + config <- mkLocalConfig locs + mapConcurrently_ (runChoreography config mainChoreo) locs + return () + where + locs = ["primary", "worker1", "worker2"] diff --git a/examples/ring-leader/Main.hs b/examples/ring-leader/Main.hs new file mode 100644 --- /dev/null +++ b/examples/ring-leader/Main.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} + +module Main where + +import Choreography +import Data.Proxy +import GHC.TypeLits (KnownSymbol) +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.State +import System.Environment + +-- an edge of the ring is represented as a tuple of two locaitons l and l' where +-- l is on the left of l' +data Edge = forall l l'. + (KnownSymbol l, KnownSymbol l') => Edge (Proxy l) (Proxy l') + +-- a ring is a sequence of edges +type Ring = [Edge] + +type Label = Int + +ringLeader :: Ring -> Choreo (StateT Label IO) () +ringLeader ring = loop ring + where + loop :: Ring -> Choreo (StateT Label IO) () + loop [] = loop ring + loop (x:xs) = do + finished <- talkToRight x + if finished + then return () + else loop xs + + talkToRight :: Edge -> Choreo (StateT Label IO) Bool + talkToRight (Edge left right) = do + labelLeft <- (left, \_ -> get) ~~> right + labelRight <- right `locally` \_ -> get + + finished <- right `locally` \un -> + return $ un labelLeft == un labelRight + + cond (right, finished) \case + True -> do + right `locally` \_ -> lift $ putStrLn "I'm the leader" + return True + False -> do + right `locally` \un -> put (max (un labelLeft) (un labelRight)) + return False + +nodeA :: Proxy "A" +nodeA = Proxy + +nodeB :: Proxy "B" +nodeB = Proxy + +nodeC :: Proxy "C" +nodeC = Proxy + +nodeD :: Proxy "D" +nodeD = Proxy + +ring = [ Edge nodeA nodeB + , Edge nodeB nodeC + , Edge nodeC nodeD + , Edge nodeD nodeA + ] + +main :: IO () +main = do + [loc] <- getArgs + putStrLn "Please input a label:" + label <- read <$> getLine + runStateT (runChoreography config (ringLeader ring) loc) label + return () + where + config = mkHttpConfig [ ("A", ("localhost", 4242)) + , ("B", ("localhost", 4343)) + , ("C", ("localhost", 4444)) + , ("D", ("localhost", 4545)) + ] diff --git a/src/Choreography.hs b/src/Choreography.hs new file mode 100644 --- /dev/null +++ b/src/Choreography.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +-- | This module defines the interface to HasChor. The client of the library is +-- highly recommended to only use constructs exported by this module. +module Choreography ( + -- * Locations and Located Values + LocTm, + LocTy, + type (@), + mkLoc, + + -- * The Choreo monad + Choreo, + -- ** Choreo operations + locally, + (~>), + (~~>), + cond, + cond', + + -- * Message transport backends + -- ** The HTTP backend + Host, + Port, + HttpConfig, + mkHttpConfig, + + -- * Running choreographies + runChoreo, + runChoreography + ) where + +import Choreography.Location +import Choreography.Choreo +import Choreography.Network +import Choreography.Network.Http +import Choreography.Network.Local +import Control.Monad.IO.Class +import Data.Proxy + +-- | Run a choreography with a message transport backend. +runChoreography :: (Backend config, MonadIO m) => config -> Choreo m a -> LocTm -> m a +runChoreography cfg choreo l = runNetwork cfg l (epp choreo l) diff --git a/src/Choreography/Choreo.hs b/src/Choreography/Choreo.hs new file mode 100644 --- /dev/null +++ b/src/Choreography/Choreo.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImpredicativeTypes #-} + +-- | This module defines `Choreo`, the monad for writing choreographies. +module Choreography.Choreo where + +import Choreography.Location +import Choreography.Network +import Control.Monad.Freer +import Data.List +import Data.Proxy +import GHC.TypeLits + +-- * The Choreo monad + +-- | A constrained version of `unwrap` that only unwraps values located at a +-- specific location. +type Unwrap l = forall a. a @ l -> a + +-- | Effect signature for the `Choreo` monad. @m@ is a monad that represents +-- local computations. +data ChoreoSig m a where + Local :: (KnownSymbol l) + => Proxy l + -> (Unwrap l -> m a) + -> ChoreoSig m (a @ l) + + Comm :: (Show a, Read a, KnownSymbol l, KnownSymbol l') + => Proxy l + -> a @ l + -> Proxy l' + -> ChoreoSig m (a @ l') + + Cond :: (Show a, Read a, KnownSymbol l) + => Proxy l + -> a @ l + -> (a -> Choreo m b) + -> ChoreoSig m b + +-- | Monad for writing choreographies. +type Choreo m = Freer (ChoreoSig m) + +-- | Run a `Choreo` monad directly. +runChoreo :: Monad m => Choreo m a -> m a +runChoreo = interpFreer handler + where + handler :: Monad m => ChoreoSig m a -> m a + handler (Local _ m) = wrap <$> m unwrap + handler (Comm _ a _) = return $ (wrap . unwrap) a + handler (Cond _ a c) = runChoreo $ c (unwrap a) + +-- | Endpoint projection. +epp :: Choreo m a -> LocTm -> Network m a +epp c l' = interpFreer handler c + where + handler :: ChoreoSig m a -> Network m a + handler (Local l m) + | toLocTm l == l' = wrap <$> run (m unwrap) + | otherwise = return Empty + handler (Comm s a r) + | toLocTm s == l' = send (unwrap a) (toLocTm r) >> return Empty + | toLocTm r == l' = wrap <$> recv (toLocTm s) + | otherwise = return Empty + handler (Cond l a c) + | toLocTm l == l' = broadcast (unwrap a) >> epp (c (unwrap a)) l' + | otherwise = recv (toLocTm l) >>= \x -> epp (c x) l' + +-- * Choreo operations + +-- | Perform a local computation at a given location. +locally :: KnownSymbol l + => Proxy l -- ^ Location performing the local computation. + -> (Unwrap l -> m a) -- ^ The local computation given a constrained + -- unwrap funciton. + -> Choreo m (a @ l) +locally l m = toFreer (Local l m) + +-- | Communication between a sender and a receiver. +(~>) :: (Show a, Read a, KnownSymbol l, KnownSymbol l') + => (Proxy l, a @ l) -- ^ A pair of a sender's location and a value located + -- at the sender + -> Proxy l' -- ^ A receiver's location. + -> Choreo m (a @ l') +(~>) (l, a) l' = toFreer (Comm l a l') + +-- | Conditionally execute choreographies based on a located value. +cond :: (Show a, Read a, KnownSymbol l) + => (Proxy l, a @ l) -- ^ A pair of a location and a scrutinee located on + -- it. + -> (a -> Choreo m b) -- ^ A function that describes the follow-up + -- choreographies based on the value of scrutinee. + -> Choreo m b +cond (l, a) c = toFreer (Cond l a c) + +-- | A variant of `~>` that sends the result of a local computation. +(~~>) :: (Show a, Read a, KnownSymbol l, KnownSymbol l') + => (Proxy l, Unwrap l -> m a) -- ^ A pair of a sender's location and a local + -- computation. + -> Proxy l' -- ^ A receiver's location. + -> Choreo m (a @ l') +(~~>) (l, m) l' = do + x <- l `locally` m + (l, x) ~> l' + +-- | A variant of `cond` that conditonally executes choregraphies based on the +-- result of a local computation. +cond' :: (Show a, Read a, KnownSymbol l) + => (Proxy l, Unwrap l -> m a) -- ^ A pair of a location and a local + -- computation. + -> (a -> Choreo m b) -- ^ A function that describes the follow-up + -- choreographies based on the result of the + -- local computation. + -> Choreo m b +cond' (l, m) c = do + x <- l `locally` m + cond (l, x) c diff --git a/src/Choreography/Location.hs b/src/Choreography/Location.hs new file mode 100644 --- /dev/null +++ b/src/Choreography/Location.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DataKinds #-} + +-- | This module defines locations and located values. +module Choreography.Location where + +import Data.Proxy +import Data.String +import GHC.TypeLits +import Language.Haskell.TH + +-- | Term-level locations. +type LocTm = String + +-- | Type-level locations. +type LocTy = Symbol + +-- | Convert a type-level location to a term-level location. +toLocTm :: forall (l :: LocTy). KnownSymbol l => Proxy l -> LocTm +toLocTm = symbolVal + +-- | Located values. +-- +-- @a \@ l@ represents a value of type @a@ at location @l@. +data a @ (l :: LocTy) + = Wrap a -- ^ A located value @a \@ l@ from location @l@'s perspective. + | Empty -- ^ A located value @a \@ l@ from locations other than @l@'s + -- perspective. + +-- | Wrap a value as a located value. +wrap :: a -> a @ l +wrap = Wrap + +-- | Unwrap a located value. +-- +-- /Note:/ Unwrapping a empty located value will throw an exception. +unwrap :: a @ l-> a +unwrap (Wrap a) = a +unwrap Empty = error "this should never happen for a well-typed choreography" + +-- | Define a location at both type and term levels. +mkLoc :: String -> Q [Dec] +mkLoc loc = do + let locName = mkName loc + let p = mkName "Data.Proxy.Proxy" + pure [SigD locName (AppT (ConT p) (LitT (StrTyLit loc))),ValD (VarP locName) (NormalB (ConE p)) []] diff --git a/src/Choreography/Network.hs b/src/Choreography/Network.hs new file mode 100644 --- /dev/null +++ b/src/Choreography/Network.hs @@ -0,0 +1,59 @@ +-- | This module defines the `Network` monad, which represents programs run on +-- individual nodes in a distributed system with explicit sends and receives. +-- To run a `Network` program, we provide a `runNetwork` function that supports +-- multiple message transport backends. +module Choreography.Network where + +import Choreography.Location +import Control.Monad.Freer +import Control.Monad.IO.Class + +-- * The Network monad + +-- | Effect signature for the `Network` monad. +data NetworkSig m a where + -- | Local computation. + Run :: m a + -> NetworkSig m a + -- | Sending. + Send :: Show a + => a + -> LocTm + -> NetworkSig m () + -- | Receiving. + Recv :: Read a + => LocTm + -> NetworkSig m a + -- | Broadcasting. + BCast :: Show a + => a + -> NetworkSig m () + +-- | Monad that represents network programs. +type Network m = Freer (NetworkSig m) + +-- * Network operations + +-- | Perform a local computation. +run :: m a -> Network m a +run m = toFreer $ Run m + +-- | Send a message to a receiver. +send :: Show a => a -> LocTm -> Network m () +send a l = toFreer $ Send a l + +-- | Receive a message from a sender. +recv :: Read a => LocTm -> Network m a +recv l = toFreer $ Recv l + +-- | Broadcast a message to all participants. +broadcast :: Show a => a -> Network m () +broadcast a = toFreer $ BCast a + +-- * Message transport backends + +-- | A message transport backend defines a /configuration/ of type @c@ that +-- carries necessary bookkeeping information, then defines @c@ as an instance +-- of `Backend` and provides a `runNetwork` function. +class Backend c where + runNetwork :: MonadIO m => c -> LocTm -> Network m a -> m a diff --git a/src/Choreography/Network/Http.hs b/src/Choreography/Network/Http.hs new file mode 100644 --- /dev/null +++ b/src/Choreography/Network/Http.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +-- | This module implments the HTTP message transport backend for the `Network` +-- monad. +module Choreography.Network.Http where + +import Choreography.Location +import Choreography.Network hiding (run) +import Data.ByteString (fromStrict) +import Data.Proxy (Proxy(..)) +import Data.HashMap.Strict (HashMap, (!)) +import Data.HashMap.Strict qualified as HashMap +import Network.HTTP.Client (Manager, defaultManagerSettings, newManager) +import Servant.API +import Servant.Client (ClientM, client, runClientM, BaseUrl(..), mkClientEnv, Scheme(..)) +import Servant.Server (Handler, Server, serve) +import Control.Concurrent +import Control.Concurrent.Chan +import Control.Monad +import Control.Monad.Freer +import Control.Monad.IO.Class +import Network.Wai.Handler.Warp (run) + +-- * Servant API + +type API = "send" :> Capture "from" LocTm :> ReqBody '[PlainText] String :> PostNoContent + +-- * Http configuration + +-- | The HTTP backend configuration specifies how locations are mapped to +-- network hosts and ports. +newtype HttpConfig = HttpConfig + { locToUrl :: HashMap LocTm BaseUrl + } + +type Host = String +type Port = Int + +-- | Create a HTTP backend configuration from a association list that maps +-- locations to network hosts and ports. +mkHttpConfig :: [(LocTm, (Host, Port))] -> HttpConfig +mkHttpConfig = HttpConfig . HashMap.fromList . fmap (fmap f) + where + f :: (Host, Port) -> BaseUrl + f (host, port) = BaseUrl + { baseUrlScheme = Http + , baseUrlHost = host + , baseUrlPort = port + , baseUrlPath = "" + } + +locs :: HttpConfig -> [LocTm] +locs = HashMap.keys . locToUrl + +-- * Receiving channels + +type RecvChans = HashMap LocTm (Chan String) + +mkRecvChans :: HttpConfig -> IO RecvChans +mkRecvChans cfg = foldM f HashMap.empty (locs cfg) + where + f :: HashMap LocTm (Chan String) -> LocTm + -> IO (HashMap LocTm (Chan String)) + f hm l = do + c <- newChan + return $ HashMap.insert l c hm + +-- * HTTP backend + +runNetworkHttp :: MonadIO m => HttpConfig -> LocTm -> Network m a -> m a +runNetworkHttp cfg self prog = do + mgr <- liftIO $ newManager defaultManagerSettings + chans <- liftIO $ mkRecvChans cfg + recvT <- liftIO $ forkIO (recvThread cfg chans) + result <- runNetworkMain mgr chans prog + liftIO $ threadDelay 1000000 -- wait until all outstanding requests to be completed + liftIO $ killThread recvT + return result + where + runNetworkMain :: MonadIO m => Manager -> RecvChans -> Network m a -> m a + runNetworkMain mgr chans = interpFreer handler + where + handler :: MonadIO m => NetworkSig m a -> m a + handler (Run m) = m + handler(Send a l) = liftIO $ do + res <- runClientM (send self $ show a) (mkClientEnv mgr (locToUrl cfg ! l)) + case res of + Left err -> putStrLn $ "Error : " ++ show err + Right _ -> return () + handler (Recv l) = liftIO $ read <$> readChan (chans ! l) + handler (BCast a) = mapM_ handler $ fmap (Send a) (locs cfg) + + api :: Proxy API + api = Proxy + + send :: LocTm -> String -> ClientM NoContent + send = client api + + server :: RecvChans -> Server API + server chans = handler + where + handler :: LocTm -> String -> Handler NoContent + handler rmt msg = do + liftIO $ writeChan (chans ! rmt) msg + return NoContent + + recvThread :: HttpConfig -> RecvChans -> IO () + recvThread cfg chans = run (baseUrlPort $ locToUrl cfg ! self ) (serve api $ server chans) + +instance Backend HttpConfig where + runNetwork = runNetworkHttp diff --git a/src/Choreography/Network/Local.hs b/src/Choreography/Network/Local.hs new file mode 100644 --- /dev/null +++ b/src/Choreography/Network/Local.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE GADTs #-} + +-- | This module defines the multi-thread backend for the `Network` monad. +module Choreography.Network.Local where + +import Choreography.Location +import Choreography.Network +import Control.Concurrent +import Control.Concurrent.Chan +import Control.Monad +import Control.Monad.Freer +import Control.Monad.IO.Class +import Data.HashMap.Strict (HashMap, (!)) +import Data.HashMap.Strict qualified as HashMap + +-- | Each location is associated with a message buffer which stores messages sent +-- from other locations. +type MsgBuf = HashMap LocTm (Chan String) + +newtype LocalConfig = LocalConfig + { locToBuf :: HashMap LocTm MsgBuf + } + +newEmptyMsgBuf :: [LocTm] -> IO MsgBuf +newEmptyMsgBuf = foldM f HashMap.empty + where + f hash loc = do + chan <- newChan + return (HashMap.insert loc chan hash) + +mkLocalConfig :: [LocTm] -> IO LocalConfig +mkLocalConfig locs = LocalConfig <$> foldM f HashMap.empty locs + where + f hash loc = do + buf <- newEmptyMsgBuf locs + return (HashMap.insert loc buf hash) + +locs :: LocalConfig -> [LocTm] +locs = HashMap.keys . locToBuf + +runNetworkLocal :: MonadIO m => LocalConfig -> LocTm -> Network m a -> m a +runNetworkLocal cfg self prog = interpFreer handler prog + where + handler :: MonadIO m => NetworkSig m a -> m a + handler (Run m) = m + handler (Send a l) = liftIO $ writeChan ((locToBuf cfg ! l) ! self) (show a) + handler (Recv l) = liftIO $ read <$> readChan ((locToBuf cfg ! self) ! l) + handler(BCast a) = mapM_ handler $ fmap (Send a) (locs cfg) + +instance Backend LocalConfig where + runNetwork = runNetworkLocal + diff --git a/src/Control/Monad/Freer.hs b/src/Control/Monad/Freer.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Freer.hs @@ -0,0 +1,43 @@ +-- | This module defines the freer monad `Freer`, which allows manipulating +-- effectful computations algebraically. +module Control.Monad.Freer where + +import Control.Monad ((>=>)) + +-- | Freer monads. +-- +-- A freer monad @Freer f a@ represents an effectful computation that returns a +-- value of type @a@. The parameter @f :: * -> *@ is a effect signature that +-- defines the effectful operations allowed in the computation. @Freer f a@ is +-- called a freer monad in that it's a `Monad` given any @f@. +data Freer f a where + -- | A pure computation. + Return :: a -> Freer f a + -- | An effectful computation where the first argument @f b@ is the effect + -- to perform and returns a result of type @b@; the second argument + -- @b -> Freer f a@ is a continuation that specifies the rest of the + -- computation given the result of the performed effect. + Do :: f b -> (b -> Freer f a) -> Freer f a + +instance Functor (Freer f) where + fmap f (Return a) = Return (f a) + fmap f (Do eff k) = Do eff (fmap f . k) + +instance Applicative (Freer f) where + pure = Return + + (Return f) <*> a = fmap f a + (Do eff k) <*> a = Do eff $ (<*> a) . k + +instance Monad (Freer f) where + (Return a) >>= f = f a + (Do eff k) >>= f = Do eff (k >=> f) + +-- | Lift an effect into the freer monad. +toFreer :: f a -> Freer f a +toFreer eff = Do eff Return + +-- | Interpret the effects in a freer monad in terms of another monad. +interpFreer :: Monad m => (forall a. f a -> m a) -> Freer f a -> m a +interpFreer handler (Return a) = return a +interpFreer handler (Do eff k) = handler eff >>= interpFreer handler . k