packages feed

HasChor (empty) → 0.1.0.1

raw patch · 25 files changed

+2341/−0 lines, 25 filesdep +HasChordep +asyncdep +base

Dependencies added: HasChor, async, base, bytestring, containers, http-client, random, servant, servant-client, servant-server, split, template-haskell, time, transformers, unordered-containers, warp

Files

+ HasChor.cabal view
@@ -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 <gan_shen@icloud.com>+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
+ LICENSE view
@@ -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.
+ README.md view
@@ -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)
+ examples/bank-2pc/Main.hs view
@@ -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
+ examples/bookseller-0-network/Main.hs view
@@ -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))+                       ]
+ examples/bookseller-1-simple/Main.hs view
@@ -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))+                       ]
+ examples/bookseller-2-higher-order/Main.hs view
@@ -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))+                       ]
+ examples/bookseller-3-loc-poly/Main.hs view
@@ -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))+                       ]
+ examples/diffiehellman/Main.hs view
@@ -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))+        ]
+ examples/karatsuba/Main.hs view
@@ -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"]
+ examples/kvs-1-simple/Main.hs view
@@ -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))+        ]
+ examples/kvs-2-primary-backup/Main.hs view
@@ -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))+        ]
+ examples/kvs-3-higher-order/Main.hs view
@@ -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))+        ]
+ examples/kvs-4-loc-poly/Main.hs view
@@ -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))+        ]
+ examples/mergesort/Main.hs view
@@ -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))+        ]
+ examples/playground/Main.hs view
@@ -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))+                       ]
+ examples/quicksort/Main.hs view
@@ -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"]
+ examples/ring-leader/Main.hs view
@@ -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))+                          ]
+ src/Choreography.hs view
@@ -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)
+ src/Choreography/Choreo.hs view
@@ -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
+ src/Choreography/Location.hs view
@@ -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)) []]
+ src/Choreography/Network.hs view
@@ -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
+ src/Choreography/Network/Http.hs view
@@ -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
+ src/Choreography/Network/Local.hs view
@@ -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+
+ src/Control/Monad/Freer.hs view
@@ -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