module Paxos
  ( app
  ) where

import qualified Data.Text.Lazy as T
import qualified Data.ByteString.Lazy.UTF8 as BLU

import Web.Scotty (ActionM, jsonData, get, post, html, text, status, pathParam, scotty, liftIO)
import Network.HTTP.Types.Status (notImplemented501, ok200, unauthorized401, conflict409, imATeapot418)
import Data.List (find)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Aeson (FromJSON, ToJSON, encode)
import GHC.Generics (Generic)
import Network.HTTP (postRequestWithBody, rspBody, rspCode, simpleHTTP)
import Network.HTTP.Base (ResponseCode)
import Control.Concurrent.STM.TVar (TVar, newTVarIO, readTVar, modifyTVar')
import GHC.Conc (atomically)
import Data.List.Split (splitOn)

data Node = Node {
  Node -> Int
nodeId :: Int,
  Node -> String
addr :: String,
  Node -> Maybe Proposer
proposer :: Maybe Proposer,
  Node -> Maybe Acceptor
acceptor :: Maybe Acceptor,
  Node -> Maybe Learner
learner :: Maybe Learner
  }
  deriving (Int -> Node -> ShowS
[Node] -> ShowS
Node -> String
(Int -> Node -> ShowS)
-> (Node -> String) -> ([Node] -> ShowS) -> Show Node
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Node -> ShowS
showsPrec :: Int -> Node -> ShowS
$cshow :: Node -> String
show :: Node -> String
$cshowList :: [Node] -> ShowS
showList :: [Node] -> ShowS
Show)

data Proposal = Proposal {
  Proposal -> Int
proposalId :: Int,
  Proposal -> Maybe String
proposalValue :: Maybe String
  }
  deriving (Int -> Proposal -> ShowS
[Proposal] -> ShowS
Proposal -> String
(Int -> Proposal -> ShowS)
-> (Proposal -> String) -> ([Proposal] -> ShowS) -> Show Proposal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Proposal -> ShowS
showsPrec :: Int -> Proposal -> ShowS
$cshow :: Proposal -> String
show :: Proposal -> String
$cshowList :: [Proposal] -> ShowS
showList :: [Proposal] -> ShowS
Show, Proposal -> Proposal -> Bool
(Proposal -> Proposal -> Bool)
-> (Proposal -> Proposal -> Bool) -> Eq Proposal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Proposal -> Proposal -> Bool
== :: Proposal -> Proposal -> Bool
$c/= :: Proposal -> Proposal -> Bool
/= :: Proposal -> Proposal -> Bool
Eq, (forall x. Proposal -> Rep Proposal x)
-> (forall x. Rep Proposal x -> Proposal) -> Generic Proposal
forall x. Rep Proposal x -> Proposal
forall x. Proposal -> Rep Proposal x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Proposal -> Rep Proposal x
from :: forall x. Proposal -> Rep Proposal x
$cto :: forall x. Rep Proposal x -> Proposal
to :: forall x. Rep Proposal x -> Proposal
Generic, Value -> Parser [Proposal]
Value -> Parser Proposal
(Value -> Parser Proposal)
-> (Value -> Parser [Proposal]) -> FromJSON Proposal
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser Proposal
parseJSON :: Value -> Parser Proposal
$cparseJSONList :: Value -> Parser [Proposal]
parseJSONList :: Value -> Parser [Proposal]
FromJSON, [Proposal] -> Value
[Proposal] -> Encoding
Proposal -> Value
Proposal -> Encoding
(Proposal -> Value)
-> (Proposal -> Encoding)
-> ([Proposal] -> Value)
-> ([Proposal] -> Encoding)
-> ToJSON Proposal
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: Proposal -> Value
toJSON :: Proposal -> Value
$ctoEncoding :: Proposal -> Encoding
toEncoding :: Proposal -> Encoding
$ctoJSONList :: [Proposal] -> Value
toJSONList :: [Proposal] -> Value
$ctoEncodingList :: [Proposal] -> Encoding
toEncodingList :: [Proposal] -> Encoding
ToJSON)

data Proposer = Proposer { Proposer -> Int
proposerId :: Int }
  deriving (Int -> Proposer -> ShowS
[Proposer] -> ShowS
Proposer -> String
(Int -> Proposer -> ShowS)
-> (Proposer -> String) -> ([Proposer] -> ShowS) -> Show Proposer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Proposer -> ShowS
showsPrec :: Int -> Proposer -> ShowS
$cshow :: Proposer -> String
show :: Proposer -> String
$cshowList :: [Proposer] -> ShowS
showList :: [Proposer] -> ShowS
Show)

data Acceptor = Acceptor {
  Acceptor -> Int
lastProposalId :: Int,
  Acceptor -> Maybe Proposal
acceptedProposal :: Maybe Proposal
  }
  deriving (Int -> Acceptor -> ShowS
[Acceptor] -> ShowS
Acceptor -> String
(Int -> Acceptor -> ShowS)
-> (Acceptor -> String) -> ([Acceptor] -> ShowS) -> Show Acceptor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Acceptor -> ShowS
showsPrec :: Int -> Acceptor -> ShowS
$cshow :: Acceptor -> String
show :: Acceptor -> String
$cshowList :: [Acceptor] -> ShowS
showList :: [Acceptor] -> ShowS
Show, Acceptor -> Acceptor -> Bool
(Acceptor -> Acceptor -> Bool)
-> (Acceptor -> Acceptor -> Bool) -> Eq Acceptor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Acceptor -> Acceptor -> Bool
== :: Acceptor -> Acceptor -> Bool
$c/= :: Acceptor -> Acceptor -> Bool
/= :: Acceptor -> Acceptor -> Bool
Eq)

data Learner = Learner {
  Learner -> Maybe Proposal
commitedProposal :: Maybe Proposal
  }
  deriving (Int -> Learner -> ShowS
[Learner] -> ShowS
Learner -> String
(Int -> Learner -> ShowS)
-> (Learner -> String) -> ([Learner] -> ShowS) -> Show Learner
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Learner -> ShowS
showsPrec :: Int -> Learner -> ShowS
$cshow :: Learner -> String
show :: Learner -> String
$cshowList :: [Learner] -> ShowS
showList :: [Learner] -> ShowS
Show, Learner -> Learner -> Bool
(Learner -> Learner -> Bool)
-> (Learner -> Learner -> Bool) -> Eq Learner
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Learner -> Learner -> Bool
== :: Learner -> Learner -> Bool
$c/= :: Learner -> Learner -> Bool
/= :: Learner -> Learner -> Bool
Eq)

initialProposer :: Proposer
initialProposer :: Proposer
initialProposer = Proposer {
  proposerId :: Int
proposerId = Int
0 -- TODO: implement monotonic counter
  }

initialAcceptor :: Acceptor
initialAcceptor :: Acceptor
initialAcceptor = Acceptor {
  lastProposalId :: Int
lastProposalId = Int
0,
  acceptedProposal :: Maybe Proposal
acceptedProposal = Maybe Proposal
forall a. Maybe a
Nothing
  }

initialLearner :: Learner
initialLearner :: Learner
initialLearner = Learner {
  commitedProposal :: Maybe Proposal
commitedProposal = Maybe Proposal
forall a. Maybe a
Nothing
  }

initialnodes :: [Node]
initialnodes :: [Node]
initialnodes = [
  Node {
    nodeId :: Int
nodeId = Int
1,
    addr :: String
addr = String
"http://0.0.0.0:4000",
    proposer :: Maybe Proposer
proposer = Proposer -> Maybe Proposer
forall a. a -> Maybe a
Just Proposer
initialProposer,
    acceptor :: Maybe Acceptor
acceptor = Maybe Acceptor
forall a. Maybe a
Nothing,
    learner :: Maybe Learner
learner = Maybe Learner
forall a. Maybe a
Nothing
    },
  Node {
    nodeId :: Int
nodeId = Int
2,
    addr :: String
addr = String
"http://0.0.0.0:4001",
    proposer :: Maybe Proposer
proposer = Maybe Proposer
forall a. Maybe a
Nothing,
    acceptor :: Maybe Acceptor
acceptor = Acceptor -> Maybe Acceptor
forall a. a -> Maybe a
Just Acceptor
initialAcceptor,
    learner :: Maybe Learner
learner = Maybe Learner
forall a. Maybe a
Nothing
    },
  Node {
    nodeId :: Int
nodeId = Int
3,
    addr :: String
addr = String
"http://0.0.0.0:4002",
    proposer :: Maybe Proposer
proposer = Proposer -> Maybe Proposer
forall a. a -> Maybe a
Just Proposer
initialProposer,
    acceptor :: Maybe Acceptor
acceptor = Acceptor -> Maybe Acceptor
forall a. a -> Maybe a
Just Acceptor
initialAcceptor,
    learner :: Maybe Learner
learner = Maybe Learner
forall a. Maybe a
Nothing
    },
  Node {
    nodeId :: Int
nodeId = Int
4,
    addr :: String
addr = String
"http://0.0.0.0:4003",
    proposer :: Maybe Proposer
proposer = Proposer -> Maybe Proposer
forall a. a -> Maybe a
Just Proposer
initialProposer,
    acceptor :: Maybe Acceptor
acceptor = Acceptor -> Maybe Acceptor
forall a. a -> Maybe a
Just Acceptor
initialAcceptor,
    learner :: Maybe Learner
learner = Maybe Learner
forall a. Maybe a
Nothing
    },
  Node {
    nodeId :: Int
nodeId = Int
5,
    addr :: String
addr = String
"http://0.0.0.0:4004",
    proposer :: Maybe Proposer
proposer = Proposer -> Maybe Proposer
forall a. a -> Maybe a
Just Proposer
initialProposer,
    acceptor :: Maybe Acceptor
acceptor = Acceptor -> Maybe Acceptor
forall a. a -> Maybe a
Just Acceptor
initialAcceptor,
    learner :: Maybe Learner
learner = Learner -> Maybe Learner
forall a. a -> Maybe a
Just Learner
initialLearner
    }
  ]

getNodes :: Int -> (Maybe Node, [Node])
getNodes :: Int -> (Maybe Node, [Node])
getNodes Int
selfId = (
  (Node -> Bool) -> [Node] -> Maybe Node
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (
    \(Node { nodeId :: Node -> Int
nodeId = Int
nodeId' }) -> Int
selfId Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
nodeId'
    ) [Node]
initialnodes,
  (Node -> Bool) -> [Node] -> [Node]
forall a. (a -> Bool) -> [a] -> [a]
filter (
    \(Node { nodeId :: Node -> Int
nodeId = Int
nodeId' }) -> Int
selfId Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
nodeId'
    ) [Node]
initialnodes
  )

getPort :: Node -> Int
getPort :: Node -> Int
getPort (Node { addr :: Node -> String
addr = String
addr' }) = String -> Int
forall a. Read a => String -> a
read (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ (String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
":" String
addr') [String] -> Int -> String
forall a. HasCallStack => [a] -> Int -> a
!! Int
2

updateAcceptorLastId :: Int -> Node -> Node
updateAcceptorLastId :: Int -> Node -> Node
updateAcceptorLastId Int
newId node' :: Node
node'@(Node { acceptor :: Node -> Maybe Acceptor
acceptor=(Just Acceptor
acceptor') }) =
  Node
node' {
    acceptor = Just $ acceptor' {
      lastProposalId = newId
      }
    }
updateAcceptorLastId Int
_ Node
n = Node
n

updateAcceptorProposal :: Proposal -> Node -> Node
updateAcceptorProposal :: Proposal -> Node -> Node
updateAcceptorProposal Proposal
newProposal node' :: Node
node'@(Node { acceptor :: Node -> Maybe Acceptor
acceptor=(Just Acceptor
acceptor') }) =
  Node
node' {
    acceptor = Just $ acceptor' {
      acceptedProposal = Just newProposal
      }
    }
updateAcceptorProposal Proposal
_ Node
n = Node
n

updateLearnerProposal :: Proposal -> Node -> Node
updateLearnerProposal :: Proposal -> Node -> Node
updateLearnerProposal Proposal
newProposal node' :: Node
node'@(Node { learner :: Node -> Maybe Learner
learner=(Just Learner
learner') }) =
  Node
node' {
    learner = Just $ learner' {
      commitedProposal = Just newProposal
      }
    }
updateLearnerProposal Proposal
_ Node
n = Node
n

createProposal :: Maybe String -> IO Proposal
createProposal :: Maybe String -> IO Proposal
createProposal Maybe String
value = do
  Int
timestamp <- (POSIXTime -> Int
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Int) -> (POSIXTime -> POSIXTime) -> POSIXTime -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* POSIXTime
1000)) (POSIXTime -> Int) -> IO POSIXTime -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO POSIXTime
getPOSIXTime
  Proposal -> IO Proposal
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Proposal -> IO Proposal) -> Proposal -> IO Proposal
forall a b. (a -> b) -> a -> b
$ Proposal { proposalId :: Int
proposalId = Int
timestamp, proposalValue :: Maybe String
proposalValue = Maybe String
value }

setupPaxos :: Int -> IO (Either String (Node, [Node]))
setupPaxos :: Int -> IO (Either String (Node, [Node]))
setupPaxos Int
selfId = do
  case Int -> (Maybe Node, [Node])
getNodes Int
selfId of
    (Maybe Node
Nothing, [Node]
_) -> Either String (Node, [Node]) -> IO (Either String (Node, [Node]))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (Node, [Node]) -> IO (Either String (Node, [Node])))
-> Either String (Node, [Node])
-> IO (Either String (Node, [Node]))
forall a b. (a -> b) -> a -> b
$ String -> Either String (Node, [Node])
forall a b. a -> Either a b
Left String
"Invalid id"
    (Just Node
self, [Node]
nodes) -> Either String (Node, [Node]) -> IO (Either String (Node, [Node]))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (Node, [Node]) -> IO (Either String (Node, [Node])))
-> Either String (Node, [Node])
-> IO (Either String (Node, [Node]))
forall a b. (a -> b) -> a -> b
$ (Node, [Node]) -> Either String (Node, [Node])
forall a b. b -> Either a b
Right (Node
self, [Node]
nodes)

sendPrepare :: Proposal -> Node -> IO (Either String ResponseCode)
sendPrepare :: Proposal -> Node -> IO (Either String ResponseCode)
sendPrepare Proposal
proposal node :: Node
node@(Node { addr :: Node -> String
addr = String
addr' }) = do
  String -> IO ()
forall a. Show a => a -> IO ()
print (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"preparing: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Proposal -> String
forall a. Show a => a -> String
show Proposal
proposal
  String -> IO ()
forall a. Show a => a -> IO ()
print (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"to: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Node -> String
forall a. Show a => a -> String
show Node
node
  String -> IO ()
forall a. Show a => a -> IO ()
print (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
addr' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/acceptor/prepare"
  Result (Response String)
response <- Request String -> IO (Result (Response String))
forall ty. HStream ty => Request ty -> IO (Result (Response ty))
simpleHTTP (Request String -> IO (Result (Response String)))
-> Request String -> IO (Result (Response String))
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> Request String
postRequestWithBody (String
addr' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/acceptor/prepare") String
"application/json" (String -> Request String) -> String -> Request String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BLU.toString (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Proposal -> ByteString
forall a. ToJSON a => a -> ByteString
encode Proposal
proposal
  case Result (Response String)
response of
    Right Response String
res -> Either String ResponseCode -> IO (Either String ResponseCode)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String ResponseCode -> IO (Either String ResponseCode))
-> Either String ResponseCode -> IO (Either String ResponseCode)
forall a b. (a -> b) -> a -> b
$ ResponseCode -> Either String ResponseCode
forall a b. b -> Either a b
Right (ResponseCode -> Either String ResponseCode)
-> ResponseCode -> Either String ResponseCode
forall a b. (a -> b) -> a -> b
$ Response String -> ResponseCode
forall a. Response a -> ResponseCode
rspCode Response String
res
    Left ConnError
err -> do
      ConnError -> IO ()
forall a. Show a => a -> IO ()
print ConnError
err
      Either String ResponseCode -> IO (Either String ResponseCode)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String ResponseCode -> IO (Either String ResponseCode))
-> Either String ResponseCode -> IO (Either String ResponseCode)
forall a b. (a -> b) -> a -> b
$ String -> Either String ResponseCode
forall a b. a -> Either a b
Left (String -> Either String ResponseCode)
-> String -> Either String ResponseCode
forall a b. (a -> b) -> a -> b
$ ConnError -> String
forall a. Show a => a -> String
show ConnError
err

sendCommit :: Proposal -> Node -> IO (Either String ResponseCode)
sendCommit :: Proposal -> Node -> IO (Either String ResponseCode)
sendCommit Proposal
proposal node :: Node
node@(Node { addr :: Node -> String
addr = String
addr' }) = do
  String -> IO ()
forall a. Show a => a -> IO ()
print (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"commiting: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Proposal -> String
forall a. Show a => a -> String
show Proposal
proposal
  String -> IO ()
forall a. Show a => a -> IO ()
print (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"to: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Node -> String
forall a. Show a => a -> String
show Node
node
  Result (Response String)
response <- Request String -> IO (Result (Response String))
forall ty. HStream ty => Request ty -> IO (Result (Response ty))
simpleHTTP (Request String -> IO (Result (Response String)))
-> Request String -> IO (Result (Response String))
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> Request String
postRequestWithBody (String
addr' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/acceptor/commit") String
"application/json" (String -> Request String) -> String -> Request String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BLU.toString (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Proposal -> ByteString
forall a. ToJSON a => a -> ByteString
encode Proposal
proposal
  case Result (Response String)
response of
    Right Response String
res -> Either String ResponseCode -> IO (Either String ResponseCode)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String ResponseCode -> IO (Either String ResponseCode))
-> Either String ResponseCode -> IO (Either String ResponseCode)
forall a b. (a -> b) -> a -> b
$ ResponseCode -> Either String ResponseCode
forall a b. b -> Either a b
Right (ResponseCode -> Either String ResponseCode)
-> ResponseCode -> Either String ResponseCode
forall a b. (a -> b) -> a -> b
$ Response String -> ResponseCode
forall a. Response a -> ResponseCode
rspCode Response String
res
    Left ConnError
err -> do
      ConnError -> IO ()
forall a. Show a => a -> IO ()
print ConnError
err
      Either String ResponseCode -> IO (Either String ResponseCode)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String ResponseCode -> IO (Either String ResponseCode))
-> Either String ResponseCode -> IO (Either String ResponseCode)
forall a b. (a -> b) -> a -> b
$ String -> Either String ResponseCode
forall a b. a -> Either a b
Left (String -> Either String ResponseCode)
-> String -> Either String ResponseCode
forall a b. (a -> b) -> a -> b
$ ConnError -> String
forall a. Show a => a -> String
show ConnError
err

sendLearner :: Proposal -> Node -> IO (Either String ResponseCode)
sendLearner :: Proposal -> Node -> IO (Either String ResponseCode)
sendLearner Proposal
proposal node :: Node
node@(Node { addr :: Node -> String
addr = String
addr' }) = do
  Result (Response String)
response <- Request String -> IO (Result (Response String))
forall ty. HStream ty => Request ty -> IO (Result (Response ty))
simpleHTTP (Request String -> IO (Result (Response String)))
-> Request String -> IO (Result (Response String))
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> Request String
postRequestWithBody (String
addr' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/learner") String
"application/json" (String -> Request String) -> String -> Request String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BLU.toString (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Proposal -> ByteString
forall a. ToJSON a => a -> ByteString
encode Proposal
proposal
  case Result (Response String)
response of
    Right Response String
res -> Either String ResponseCode -> IO (Either String ResponseCode)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String ResponseCode -> IO (Either String ResponseCode))
-> Either String ResponseCode -> IO (Either String ResponseCode)
forall a b. (a -> b) -> a -> b
$ ResponseCode -> Either String ResponseCode
forall a b. b -> Either a b
Right (ResponseCode -> Either String ResponseCode)
-> ResponseCode -> Either String ResponseCode
forall a b. (a -> b) -> a -> b
$ Response String -> ResponseCode
forall a. Response a -> ResponseCode
rspCode Response String
res
    Left ConnError
err -> do
      ConnError -> IO ()
forall a. Show a => a -> IO ()
print ConnError
err
      Either String ResponseCode -> IO (Either String ResponseCode)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String ResponseCode -> IO (Either String ResponseCode))
-> Either String ResponseCode -> IO (Either String ResponseCode)
forall a b. (a -> b) -> a -> b
$ String -> Either String ResponseCode
forall a b. a -> Either a b
Left (String -> Either String ResponseCode)
-> String -> Either String ResponseCode
forall a b. (a -> b) -> a -> b
$ ConnError -> String
forall a. Show a => a -> String
show ConnError
err

postProposal :: TVar Node -> [Node] -> ActionM ()
postProposal :: TVar Node -> [Node] -> ActionM ()
postProposal TVar Node
stateTM [Node]
acceptors = do
  Maybe String
value :: Maybe String <- ActionM (Maybe String)
forall a. FromJSON a => ActionM a
jsonData
  Proposal
proposal <- IO Proposal -> ActionT IO Proposal
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Proposal -> ActionT IO Proposal)
-> IO Proposal -> ActionT IO Proposal
forall a b. (a -> b) -> a -> b
$ Maybe String -> IO Proposal
createProposal Maybe String
value
  Node
self <- IO Node -> ActionT IO Node
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Node -> ActionT IO Node)
-> (STM Node -> IO Node) -> STM Node -> ActionT IO Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Node -> IO Node
forall a. STM a -> IO a
atomically (STM Node -> ActionT IO Node) -> STM Node -> ActionT IO Node
forall a b. (a -> b) -> a -> b
$ TVar Node -> STM Node
forall a. TVar a -> STM a
readTVar TVar Node
stateTM
  case Node
self of
    Node { proposer :: Node -> Maybe Proposer
proposer=(Just Proposer
proposer') } -> do
      IO () -> ActionM ()
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> (String -> IO ()) -> String -> ActionM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
forall a. Show a => a -> IO ()
print (String -> ActionM ()) -> String -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String
"proposer: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Proposer -> String
forall a. Show a => a -> String
show Proposer
proposer'
      [Either String ResponseCode]
responses <- IO [Either String ResponseCode]
-> ActionT IO [Either String ResponseCode]
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Either String ResponseCode]
 -> ActionT IO [Either String ResponseCode])
-> IO [Either String ResponseCode]
-> ActionT IO [Either String ResponseCode]
forall a b. (a -> b) -> a -> b
$ [IO (Either String ResponseCode)]
-> IO [Either String ResponseCode]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([IO (Either String ResponseCode)]
 -> IO [Either String ResponseCode])
-> [IO (Either String ResponseCode)]
-> IO [Either String ResponseCode]
forall a b. (a -> b) -> a -> b
$ (Node -> IO (Either String ResponseCode))
-> [Node] -> [IO (Either String ResponseCode)]
forall a b. (a -> b) -> [a] -> [b]
map (Proposal -> Node -> IO (Either String ResponseCode)
sendPrepare Proposal
proposal) [Node]
acceptors
      IO () -> ActionM ()
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> (String -> IO ()) -> String -> ActionM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
forall a. Show a => a -> IO ()
print (String -> ActionM ()) -> String -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String
"responses: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Either String ResponseCode] -> String
forall a. Show a => a -> String
show [Either String ResponseCode]
responses
      let majority :: Int
majority = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (([Node] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Node]
acceptors) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
      let successes :: Int
successes = [Either String ResponseCode] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Either String ResponseCode] -> Int)
-> [Either String ResponseCode] -> Int
forall a b. (a -> b) -> a -> b
$ (Either String ResponseCode -> Bool)
-> [Either String ResponseCode] -> [Either String ResponseCode]
forall a. (a -> Bool) -> [a] -> [a]
filter (Either String ResponseCode -> Either String ResponseCode -> Bool
forall a. Eq a => a -> a -> Bool
== ResponseCode -> Either String ResponseCode
forall a b. b -> Either a b
Right (Int
2, Int
0, Int
0)) [Either String ResponseCode]
responses
      if Int
majority Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
successes
        then do
          Status -> ActionM ()
status Status
conflict409 
          Text -> ActionM ()
text Text
"Error while preparing"
        else do
          [Either String ResponseCode]
responses' <- IO [Either String ResponseCode]
-> ActionT IO [Either String ResponseCode]
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Either String ResponseCode]
 -> ActionT IO [Either String ResponseCode])
-> IO [Either String ResponseCode]
-> ActionT IO [Either String ResponseCode]
forall a b. (a -> b) -> a -> b
$ [IO (Either String ResponseCode)]
-> IO [Either String ResponseCode]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([IO (Either String ResponseCode)]
 -> IO [Either String ResponseCode])
-> [IO (Either String ResponseCode)]
-> IO [Either String ResponseCode]
forall a b. (a -> b) -> a -> b
$ (Node -> IO (Either String ResponseCode))
-> [Node] -> [IO (Either String ResponseCode)]
forall a b. (a -> b) -> [a] -> [b]
map (Proposal -> Node -> IO (Either String ResponseCode)
sendCommit Proposal
proposal) [Node]
acceptors
          let successes' :: Int
successes' = [Either String ResponseCode] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Either String ResponseCode] -> Int)
-> [Either String ResponseCode] -> Int
forall a b. (a -> b) -> a -> b
$ (Either String ResponseCode -> Bool)
-> [Either String ResponseCode] -> [Either String ResponseCode]
forall a. (a -> Bool) -> [a] -> [a]
filter (Either String ResponseCode -> Either String ResponseCode -> Bool
forall a. Eq a => a -> a -> Bool
== ResponseCode -> Either String ResponseCode
forall a b. b -> Either a b
Right (Int
2, Int
0, Int
0)) [Either String ResponseCode]
responses'
          if Int
majority Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
successes'
            then do
              Status -> ActionM ()
status Status
conflict409
              Text -> ActionM ()
text Text
"Error while commiting"
            else Status -> ActionM ()
status Status
ok200
    Node
_ -> Status -> ActionM ()
status Status
unauthorized401

postPrepare :: TVar Node -> ActionM ()
postPrepare :: TVar Node -> ActionM ()
postPrepare TVar Node
stateTM = do
  Proposal
proposal :: Proposal <- ActionT IO Proposal
forall a. FromJSON a => ActionM a
jsonData
  IO () -> ActionM ()
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> (String -> IO ()) -> String -> ActionM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
forall a. Show a => a -> IO ()
print (String -> ActionM ()) -> String -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String
"prepare received: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Proposal -> String
forall a. Show a => a -> String
show Proposal
proposal
  Node
self' <- IO Node -> ActionT IO Node
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Node -> ActionT IO Node)
-> (STM Node -> IO Node) -> STM Node -> ActionT IO Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Node -> IO Node
forall a. STM a -> IO a
atomically (STM Node -> ActionT IO Node) -> STM Node -> ActionT IO Node
forall a b. (a -> b) -> a -> b
$ TVar Node -> STM Node
forall a. TVar a -> STM a
readTVar TVar Node
stateTM
  IO () -> ActionM ()
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> (String -> IO ()) -> String -> ActionM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
forall a. Show a => a -> IO ()
print (String -> ActionM ()) -> String -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String
"prepare state: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Node -> String
forall a. Show a => a -> String
show Node
self'
  case Node
self' of
    Node { acceptor :: Node -> Maybe Acceptor
acceptor=(Just Acceptor
acceptor') } -> do
      if Acceptor -> Int
lastProposalId Acceptor
acceptor' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Proposal -> Int
proposalId Proposal
proposal
        then do
          Status -> ActionM ()
status Status
conflict409
          Text -> ActionM ()
text Text
"Error while being prepared"
        else do
          IO () -> ActionM ()
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> (STM () -> IO ()) -> STM () -> ActionM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> ActionM ()) -> STM () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ TVar Node -> (Node -> Node) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Node
stateTM ((Node -> Node) -> STM ()) -> (Node -> Node) -> STM ()
forall a b. (a -> b) -> a -> b
$ Int -> Node -> Node
updateAcceptorLastId (Int -> Node -> Node) -> Int -> Node -> Node
forall a b. (a -> b) -> a -> b
$ Proposal -> Int
proposalId Proposal
proposal
          Node
self <- IO Node -> ActionT IO Node
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Node -> ActionT IO Node)
-> (STM Node -> IO Node) -> STM Node -> ActionT IO Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Node -> IO Node
forall a. STM a -> IO a
atomically (STM Node -> ActionT IO Node) -> STM Node -> ActionT IO Node
forall a b. (a -> b) -> a -> b
$ TVar Node -> STM Node
forall a. TVar a -> STM a
readTVar TVar Node
stateTM
          IO () -> ActionM ()
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> IO () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"prepare state: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Node -> String
forall a. Show a => a -> String
show Node
self
          -- TODO: drop timestamp and use a distributed monotonic counter
          -- text $ T.pack $ show $ lastProposalId acceptor'
          Status -> ActionM ()
status Status
ok200
    Node
_ -> Status -> ActionM ()
status Status
unauthorized401

postCommit :: TVar Node -> [Node] -> ActionM ()
postCommit :: TVar Node -> [Node] -> ActionM ()
postCommit TVar Node
stateTM [Node]
learners = do
  Proposal
proposal :: Proposal <- ActionT IO Proposal
forall a. FromJSON a => ActionM a
jsonData
  IO () -> ActionM ()
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> IO () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"commit received: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Proposal -> String
forall a. Show a => a -> String
show Proposal
proposal
  Node
self' <- IO Node -> ActionT IO Node
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Node -> ActionT IO Node)
-> (STM Node -> IO Node) -> STM Node -> ActionT IO Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Node -> IO Node
forall a. STM a -> IO a
atomically (STM Node -> ActionT IO Node) -> STM Node -> ActionT IO Node
forall a b. (a -> b) -> a -> b
$ TVar Node -> STM Node
forall a. TVar a -> STM a
readTVar TVar Node
stateTM
  IO () -> ActionM ()
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> IO () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"commit state: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Node -> String
forall a. Show a => a -> String
show Node
self'
  case Node
self' of
    Node { acceptor :: Node -> Maybe Acceptor
acceptor=(Just Acceptor
acceptor') } -> do
      if Acceptor -> Int
lastProposalId Acceptor
acceptor' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Proposal -> Int
proposalId Proposal
proposal
        then do
          Status -> ActionM ()
status Status
conflict409
          Text -> ActionM ()
text Text
"Error while being commited"
        else do
          IO [Either String ResponseCode]
-> ActionT IO [Either String ResponseCode]
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Either String ResponseCode]
 -> ActionT IO [Either String ResponseCode])
-> IO [Either String ResponseCode]
-> ActionT IO [Either String ResponseCode]
forall a b. (a -> b) -> a -> b
$ [IO (Either String ResponseCode)]
-> IO [Either String ResponseCode]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([IO (Either String ResponseCode)]
 -> IO [Either String ResponseCode])
-> [IO (Either String ResponseCode)]
-> IO [Either String ResponseCode]
forall a b. (a -> b) -> a -> b
$ (Node -> IO (Either String ResponseCode))
-> [Node] -> [IO (Either String ResponseCode)]
forall a b. (a -> b) -> [a] -> [b]
map (Proposal -> Node -> IO (Either String ResponseCode)
sendLearner Proposal
proposal) [Node]
learners
          IO () -> ActionM ()
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> (STM () -> IO ()) -> STM () -> ActionM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> ActionM ()) -> STM () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ TVar Node -> (Node -> Node) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Node
stateTM ((Node -> Node) -> STM ()) -> (Node -> Node) -> STM ()
forall a b. (a -> b) -> a -> b
$ Proposal -> Node -> Node
updateAcceptorProposal Proposal
proposal
          Node
self <- IO Node -> ActionT IO Node
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Node -> ActionT IO Node)
-> (STM Node -> IO Node) -> STM Node -> ActionT IO Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Node -> IO Node
forall a. STM a -> IO a
atomically (STM Node -> ActionT IO Node) -> STM Node -> ActionT IO Node
forall a b. (a -> b) -> a -> b
$ TVar Node -> STM Node
forall a. TVar a -> STM a
readTVar TVar Node
stateTM
          IO () -> ActionM ()
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> IO () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"commit state: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Node -> String
forall a. Show a => a -> String
show Node
self
          Status -> ActionM ()
status Status
ok200
    Node
_ -> Status -> ActionM ()
status Status
unauthorized401

getProposal :: TVar Node -> ActionM ()
getProposal :: TVar Node -> ActionM ()
getProposal TVar Node
stateTM = do
  Node
self' <- IO Node -> ActionT IO Node
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Node -> ActionT IO Node)
-> (STM Node -> IO Node) -> STM Node -> ActionT IO Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Node -> IO Node
forall a. STM a -> IO a
atomically (STM Node -> ActionT IO Node) -> STM Node -> ActionT IO Node
forall a b. (a -> b) -> a -> b
$ TVar Node -> STM Node
forall a. TVar a -> STM a
readTVar TVar Node
stateTM
  case Node
self' of
    Node { acceptor :: Node -> Maybe Acceptor
acceptor=(Just Acceptor
acceptor') } -> do
      Text -> ActionM ()
text (Text -> ActionM ()) -> Text -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Maybe Proposal -> String
forall a. Show a => a -> String
show (Maybe Proposal -> String) -> Maybe Proposal -> String
forall a b. (a -> b) -> a -> b
$ Acceptor -> Maybe Proposal
acceptedProposal Acceptor
acceptor'
    Node
_ -> Status -> ActionM ()
status Status
unauthorized401

postLearner :: TVar Node -> ActionM ()
postLearner :: TVar Node -> ActionM ()
postLearner TVar Node
stateTM = do
  Proposal
proposal :: Proposal <- ActionT IO Proposal
forall a. FromJSON a => ActionM a
jsonData
  IO () -> ActionM ()
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> IO () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"learn received: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Proposal -> String
forall a. Show a => a -> String
show Proposal
proposal
  Node
self' <- IO Node -> ActionT IO Node
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Node -> ActionT IO Node)
-> (STM Node -> IO Node) -> STM Node -> ActionT IO Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Node -> IO Node
forall a. STM a -> IO a
atomically (STM Node -> ActionT IO Node) -> STM Node -> ActionT IO Node
forall a b. (a -> b) -> a -> b
$ TVar Node -> STM Node
forall a. TVar a -> STM a
readTVar TVar Node
stateTM
  IO () -> ActionM ()
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> IO () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"learn state: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Node -> String
forall a. Show a => a -> String
show Node
self'
  case Node
self' of
    Node { learner :: Node -> Maybe Learner
learner=(Just Learner
learner') } -> do
      IO () -> ActionM ()
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> (STM () -> IO ()) -> STM () -> ActionM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> ActionM ()) -> STM () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ TVar Node -> (Node -> Node) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Node
stateTM ((Node -> Node) -> STM ()) -> (Node -> Node) -> STM ()
forall a b. (a -> b) -> a -> b
$ Proposal -> Node -> Node
updateLearnerProposal Proposal
proposal
      Status -> ActionM ()
status Status
ok200
    Node
_ -> Status -> ActionM ()
status Status
unauthorized401

getLearner :: TVar Node -> ActionM ()
getLearner :: TVar Node -> ActionM ()
getLearner TVar Node
stateTM = do
  Node
self' <- IO Node -> ActionT IO Node
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Node -> ActionT IO Node)
-> (STM Node -> IO Node) -> STM Node -> ActionT IO Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Node -> IO Node
forall a. STM a -> IO a
atomically (STM Node -> ActionT IO Node) -> STM Node -> ActionT IO Node
forall a b. (a -> b) -> a -> b
$ TVar Node -> STM Node
forall a. TVar a -> STM a
readTVar TVar Node
stateTM
  case Node
self' of
    Node { learner :: Node -> Maybe Learner
learner=(Just Learner
learner') } -> do
      Text -> ActionM ()
text (Text -> ActionM ()) -> Text -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Maybe Proposal -> String
forall a. Show a => a -> String
show (Maybe Proposal -> String) -> Maybe Proposal -> String
forall a b. (a -> b) -> a -> b
$ Learner -> Maybe Proposal
commitedProposal Learner
learner'
    Node
_ -> Status -> ActionM ()
status Status
unauthorized401

app :: Int -> IO ()
app :: Int -> IO ()
app Int
selfId = do
  Either String (Node, [Node])
paxos <- Int -> IO (Either String (Node, [Node]))
setupPaxos Int
selfId
  case Either String (Node, [Node])
paxos of
    Right (Node
self, [Node]
nodes) -> do
      let acceptors :: [Node]
acceptors = (Node -> Bool) -> [Node] -> [Node]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Node { acceptor :: Node -> Maybe Acceptor
acceptor=Maybe Acceptor
acceptor' }) -> Maybe Acceptor
forall a. Maybe a
Nothing Maybe Acceptor -> Maybe Acceptor -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Acceptor
acceptor') [Node]
nodes
      let learners :: [Node]
learners = (Node -> Bool) -> [Node] -> [Node]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Node { learner :: Node -> Maybe Learner
learner=Maybe Learner
learner' }) -> Maybe Learner
forall a. Maybe a
Nothing Maybe Learner -> Maybe Learner -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Learner
learner') [Node]
nodes
      TVar Node
state :: TVar Node <- Node -> IO (TVar Node)
forall a. a -> IO (TVar a)
newTVarIO Node
self
      Int -> ScottyM () -> IO ()
scotty (Node -> Int
getPort Node
self) (ScottyM () -> IO ()) -> ScottyM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        RoutePattern -> ActionM () -> ScottyM ()
post RoutePattern
"/proposer" (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ TVar Node -> [Node] -> ActionM ()
postProposal TVar Node
state [Node]
acceptors
        RoutePattern -> ActionM () -> ScottyM ()
post RoutePattern
"/acceptor/prepare" (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ TVar Node -> ActionM ()
postPrepare TVar Node
state
        RoutePattern -> ActionM () -> ScottyM ()
post RoutePattern
"/acceptor/commit" (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ TVar Node -> [Node] -> ActionM ()
postCommit TVar Node
state [Node]
learners
        RoutePattern -> ActionM () -> ScottyM ()
get RoutePattern
"/acceptor/debug" (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ TVar Node -> ActionM ()
getProposal TVar Node
state
        RoutePattern -> ActionM () -> ScottyM ()
post RoutePattern
"/learner" (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ TVar Node -> ActionM ()
postLearner TVar Node
state
        RoutePattern -> ActionM () -> ScottyM ()
get RoutePattern
"/learner" (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ TVar Node -> ActionM ()
getLearner TVar Node
state
        RoutePattern -> ActionM () -> ScottyM ()
post RoutePattern
"/" (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
          Status -> ActionM ()
status Status
imATeapot418
          Text -> ActionM ()
text Text
"Hello World"
    Left String
err -> String -> IO ()
forall a. Show a => a -> IO ()
print String
err