voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

merged

This commit is contained in:
Dmitry Zuikov 2023-09-15 19:38:32 +03:00
parent bd2c0e0367
commit 09e070e38f
32 changed files with 2416 additions and 676 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.hlint.yaml Normal file
View File

@ -0,0 +1,6 @@
- ignore: {name: "Use infix"} # 2 hints
- ignore: {name: "Use let"} # 4 hints
- ignore: {name: "Use newtype instead of data"} # 4 hints
- ignore: {name: "Use print"} # 1 hint
- ignore: {name: "Redundant bracket Found"} # 1 hint
- ignore: {name: "Redundant $"} # 1 hint

3
Makefile
View File

@ -18,3 +18,6 @@ build:
test-core:
> nix develop -c cabal run hbs2-core:test
.PHONY: test-raft
test-raft:
> nix develop -c ghcid -c 'cabal repl' raft-algo -T RaftAlgo.Proto.devTest

1
cabal.project
View File

@ -1,4 +1,5 @@
packages: **/*.cabal
examples/*/*.cabal
-- allow-newer: all

0
examples/raft-algo/LICENSE Normal file
View File

5
examples/raft-algo/app/RaftAlgoMain.hs Normal file
View File

@ -0,0 +1,5 @@
module Main where
main :: IO ()
main = do
pure ()

836
examples/raft-algo/lib/RaftAlgo/Proto.hs Normal file
View File

@ -0,0 +1,836 @@
-- {-# Language AllowAmbiguousTypes #-}
-- {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StrictData #-}
module RaftAlgo.Proto where
import HBS2.Prelude.Plated
import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.Cont
import Control.Monad.Error.Class
import Control.Monad.State.Strict
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Writer as W
import Data.Either
import Data.Foldable qualified as F
import Data.Function
import Data.Generics.Labels
import Data.Generics.Product
import Data.Generics.Sum
import Data.Heap (Heap)
import Data.Heap qualified as Heap
import Data.Kind
import Data.List qualified as List
import Data.Map (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.Ord
import Data.Sequence (Seq(..))
import Data.Sequence qualified as Seq
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Time
import Data.Time.Calendar.OrdinalDate
import Data.Void
import Lens.Micro.Platform as Lens
import Numeric.Natural
import Streaming
import Streaming.Prelude qualified as Streaming
import System.Random.MWC as MWC
import System.Random.Stateful
newtype Term = Term { unTerm :: Int }
deriving (Eq, Ord, Num, Enum, Show)
-- | `p` - identity of a node
-- `a` - payload (reflog hash for example)
data LogEntry p a = LogEntry
{ entryTerm :: Term
, entryStateMachineCommand :: StateMachineCommand p a
}
deriving (Generic, Show)
data StateMachineCommand p a
= SMCLoad a
-- | SMAddNode p
-- | SMDropNode p
deriving (Generic, Show)
-- Должно сохраняться надёжно:
-- currentTerm
-- votedFor
-- log[]
data PersMethods p a m = PersMethods
{ getCurrentTerm :: m Term
, setCurrentTerm :: Term -> m ()
--
, getVotedFor :: m (Maybe p)
, setVotedFor :: Maybe p -> m ()
--
-- log[] ..
, getLogEntry :: Int -> m (Maybe (LogEntry p a))
, setLogEntry :: Int -> LogEntry p a -> m ()
, getLogEntriesFrom :: Int -> m [LogEntry p a]
, getLastLogIndex :: m Int
--
, getOurID :: m p
}
getLastLogIndexNTerm :: Monad m => PersMethods p a m -> m (Int, Term)
getLastLogIndexNTerm PersMethods{..} = do
lastLogIndex <- getLastLogIndex
(lastLogIndex, ) <$>
if lastLogIndex > 0
then maybe 0 entryTerm <$> getLogEntry lastLogIndex
else pure 0
hoistMethods ::
(forall a. m a -> n a)
-> PersMethods p a m
-> PersMethods p a n
hoistMethods nt h = PersMethods
{ getCurrentTerm = nt $ getCurrentTerm h
, setCurrentTerm = nt . setCurrentTerm h
--
, getVotedFor = nt $ getVotedFor h
, setVotedFor = nt . setVotedFor h
--
, getLogEntry = nt . getLogEntry h
, setLogEntry = \j le -> nt $ setLogEntry h j le
, getLogEntriesFrom = nt . getLogEntriesFrom h
, getLastLogIndex = nt $ getLastLogIndex h
--
, getOurID = nt $ getOurID h
}
data RaftState p = RaftState
{ commitIndex :: Int
, lastAppliedIndex :: Int
, actorState :: ActorState p
, cluster :: Set p
}
deriving (Generic, Show)
data ActorState p
= StateFollower
| StateCandidate
{ votesCollected :: Set p
}
| StateLeader
{ nextIndex :: Map p Int
, matchIndex :: Map p Int
}
deriving (Generic, Eq, Ord, Show)
---
data RequestVote p = RequestVote
{ requestVoteTerm :: Term
, requestVoteCandidateID :: p
, requestVoteCandidateLastLogIndex :: Int
, requestVoteCandidateLastLogTerm :: Term
}
deriving (Generic, Show)
data AppendEntries p a = AppendEntries
{ appendEntriesTerm :: Term
, appendEntriesLeaderID :: p
, appendEntriesPrevLogIndex :: Int
, appendEntriesPrevLogTerm :: Term
, appendEntriesES :: [LogEntry p a]
, appendEntriesLeaderCommitIndex :: Int
}
deriving (Generic, Show)
data ProcCall p a
= CallRequestVote (RequestVote p)
| RequestVoteReply
{ requestVoteReplyTerm :: Term
, requestVoteReplyGranted :: Bool
, requestVoteReplyFromID :: p
}
| CallAppendEntries (AppendEntries p a)
| AppendEntriesReply
{ appendEntriesReplyTerm :: Term
, appendEntriesReplySuccess :: Bool
, appendEntriesReplyFromID :: p
}
deriving (Generic, Show)
data NodeEvent p a
= ElectionTimeoutElapses
| LeaderHeartbeat
| GotProcCall (ProcCall p a)
| GotClientCall (StateMachineCommand p a)
deriving (Show)
data NodeAction p a
= ResetElectionTimer
| ResetLeaderHeartbeat
| UpdateState (RaftState p -> RaftState p)
| SwitchRole (ActorState p)
| LogMessage Text
| CallProc p (ProcCall p a)
| ReplyProc p (ProcCall p a)
| ReplyToClientWhoIsLeader (Maybe p)
---
-- Test cluster runner
data TestLogState p a = TestLogState
{ testLogStateCurrentTerm :: Term
, testLogStateVotedFor :: Maybe p
, testLogStateLog :: Seq (LogEntry p a)
, testLogStateRaftState :: RaftState p
, testLogStateNodeID :: p
}
deriving (Generic, Show)
newtype NodeID a = NodeID a
deriving newtype (Show, Eq, Ord, Num, Enum)
type NodeIDInt = NodeID Int
newtype TestData = TestData Text
deriving newtype (Show, Eq, Ord, IsString)
data TestEvent t = TestEvent
{ testEventTime :: t
, testEvent :: NodeEvent NodeIDInt TestData
}
deriving (Generic)
data TestClusterState = TestClusterState
{ testClusterNodes :: Map NodeIDInt (TestLogState NodeIDInt TestData)
, testClusterEvents :: Heap (Heap.Entry UTCTime (
Either
(NodeEvent NodeIDInt TestData, [TestEvent UTCTime])
(NodeIDInt, NodeEvent NodeIDInt TestData)
))
, testClusterElectionTimeouts :: Map NodeIDInt Int
}
deriving (Generic)
devTest :: IO ()
devTest = do
evalTestCluster 5 commands $ Streaming.take 142 >>> Streaming.mapM display >>> Streaming.effects
where
display = List.uncons >>> mapM_ \(x,xs') -> liftIO do
putStrLn (T.unpack x)
forM_ xs' \x' -> do
putStr " "
putStrLn (T.unpack x')
putStrLn ""
commands :: [TestEvent NominalDiffTime]
commands = [
TestEvent 9 (GotClientCall (SMCLoad "Tx1"))
, TestEvent 1 (GotClientCall (SMCLoad "Tx2"))
, TestEvent 3 (GotClientCall (SMCLoad "Tx3"))
, TestEvent 2 (GotClientCall (SMCLoad "Tx4"))
]
evalTestCluster ::
( Monad m
, m' ~ StateT TestClusterState (StateT StdGen m)
)
=> Int
-> [TestEvent NominalDiffTime]
-> (Stream (Of [Text]) m' () -> m' ())
-> m ()
evalTestCluster clusterSize cevs sf =
runStateGenT_ (mkStdGen randomSeed) \g -> do
initialNodeTimeouts <- forM nodeIDs \p -> do
dt <- realToFrac @Double <$> MWC.uniformRM (minElectionTimeout, maxElectionTimeout) g
pure $ Heap.Entry (addUTCTime dt timeBegin) (Right (p, ElectionTimeoutElapses))
evalStateT (
sf $
fix \go ->
lift (clusterStep g) >>= either
(\e -> Streaming.each [[e]])
(\es -> do
Streaming.each [es]
go
)
)
TestClusterState
{ testClusterNodes = Map.fromList $ nodeIDs <&> (id &&& mkTestNodeState (Set.fromList nodeIDs))
, testClusterEvents = Heap.fromList $ tcevs <> initialNodeTimeouts
, testClusterElectionTimeouts = mempty
}
where
randomSeed = 1
minElectionTimeout :: Double
minElectionTimeout = 5
maxElectionTimeout = minElectionTimeout * 2
heartbeatPeriod :: NominalDiffTime
heartbeatPeriod = realToFrac (minElectionTimeout * 3 / 4)
nodeIDs = fromIntegral <$> [1..clusterSize]
timeBegin :: UTCTime
timeBegin = UTCTime (YearDay 2000 1) 0
tcevs = case integrateTestEventTimes timeBegin cevs of
[] -> []
(TestEvent t1 ev1):clientEvents ->
[Heap.Entry t1 (Left (ev1, clientEvents))]
integrateTestEventTimes :: UTCTime -> [TestEvent NominalDiffTime] -> [TestEvent UTCTime]
integrateTestEventTimes t0 = flip evalState t0 . mapM \ev -> do
upd <- addUTCTime (ev ^. #testEventTime) <$> get
put upd
pure $ ev & #testEventTime .~ upd
mkTestNodeState :: Set NodeIDInt -> NodeIDInt -> TestLogState NodeIDInt TestData
mkTestNodeState allNodeIDs nodeID = TestLogState
{ testLogStateCurrentTerm = 0
, testLogStateVotedFor = Nothing
, testLogStateLog = mempty
, testLogStateRaftState =
RaftState
{ commitIndex = 0
, lastAppliedIndex = 0
, actorState = StateFollower
, cluster = allNodeIDs
}
, testLogStateNodeID = nodeID
}
clusterStep :: (Monad m, StatefulGen (StateGenM StdGen) m)
=> StateGenM StdGen -> StateT TestClusterState m (Either Text [Text])
clusterStep g = runExceptT do
(Heap.Entry tnow tev, heapRest) <- justOrThrowError "no events"
$ gets (Heap.uncons . view #testClusterEvents)
#testClusterEvents .= heapRest
case tev of
-- Запрос от клиента
Left (ev, tevs) -> do
case tevs of
(TestEvent tnext evnext):tevs' -> do
#testClusterEvents %= mappend do
Heap.singleton (Heap.Entry tnext (Left (evnext, tevs')))
[] -> pure ()
clusterSize <- gets (Map.size . view #testClusterNodes)
targetNodeID <- lift . lift $ fromIntegral <$> MWC.uniformRM (1, clusterSize) g
runEvent tnow targetNodeID ev
-- Событие от ноды для ноды nodeID
Right (nodeID, ev :: NodeEvent NodeIDInt TestData) ->
runEvent tnow nodeID ev
where
runEvent tnow nodeID ev = fromMaybe [] <$> runMaybeT do
case ev of
ElectionTimeoutElapses -> do
x <- #testClusterElectionTimeouts . Lens.at nodeID . non 1 <%= pred
when (x > 0) do
fail "old timeout droped"
_ -> pure ()
lift do
nodeState :: TestLogState NodeIDInt TestData
<- justOrThrowError ("no state for node " <> showt nodeID)
$ gets $ preview (#testClusterNodes . ix nodeID)
let testactions :: [TestNodeAction]
(testactions, nodeState') = flip runState nodeState (nodeTestStep ev)
#testClusterNodes . ix nodeID .= nodeState'
-- pure (Just nodeID, ev, mempty, testactions)
-- [(NominalDiffTime, (NodeIDInt, NodeEvent NodeIDInt TestData))]
(newevents, log :: [Text]) <- W.runWriterT $ catMaybes <$> forM testactions \case
TestResetElectionTimer -> do
dt <- lift . lift . lift $ realToFrac @Double
<$> MWC.uniformRM (minElectionTimeout, maxElectionTimeout) g
-- Как сбрасывать предыдущие таймеры?
-- В словарике testClusterElectionTimeouts по ключам
-- будем считать сколько добавлено новых
-- TestResetElectionTimer Событие кидать только если
-- оно соответствует единственной оставшейся записи.
x <- #testClusterElectionTimeouts . Lens.at nodeID . non 1 <<%= succ
-- W.tell [showt x]
pure $ Just $
(dt, (nodeID, ElectionTimeoutElapses))
TestResetLeaderHeartbeat ->
pure $ Just $
(heartbeatPeriod, (nodeID, LeaderHeartbeat))
TestApplyLogEntryToSM t -> pure Nothing
TestLogMessage t -> pure Nothing
TestCallProc nodeID pcall -> do
dt <- lift . lift . lift $ realToFrac @Double
<$> MWC.uniformRM (0.01, 0.1) g
pure $ Just $
(dt, (nodeID, GotProcCall pcall))
TestReplyProc nodeID pcall -> do
dt <- lift . lift . lift $ realToFrac @Double
<$> MWC.uniformRM (0.01, 0.1) g
pure $ Just $
(dt, (nodeID, GotProcCall pcall))
TestReplyToClientWhoIsLeader mnodeID -> forM mnodeID \nodeID -> do
dt <- lift . lift . lift $ realToFrac @Double
<$> MWC.uniformRM (0.3, 1) g
pure (dt, (nodeID, ev))
#testClusterEvents %= mappend do
Heap.fromList (newevents <&> \(t',ev') -> Heap.Entry (addUTCTime t' tnow) (Right ev'))
nodeStates <- gets (view #testClusterNodes)
-- pure [showt (tnow, nodeID, ev, "->", testactions ^.. traverse . _Ctor @"TestLogMessage")]
pure $ ([showt $ (tnow, nodeID, ev)]
<> (showt <$> (testactions ^.. traverse))
<> log
<> ["states:"]
<> (showt <$> Map.elems (nodeStates))
)
showt :: Show a => a -> Text
showt = T.pack . show
data TestNodeAction
= TestResetElectionTimer
| TestResetLeaderHeartbeat
| TestApplyLogEntryToSM TestData
| TestLogMessage Text
| TestCallProc NodeIDInt (ProcCall NodeIDInt TestData)
| TestReplyProc NodeIDInt (ProcCall NodeIDInt TestData)
| TestReplyToClientWhoIsLeader (Maybe NodeIDInt)
deriving (Generic, Show)
nodeTestStep :: forall m. (Monad m)
=> NodeEvent NodeIDInt TestData
-> StateT (TestLogState NodeIDInt TestData) m [TestNodeAction]
nodeTestStep ev = do
let h :: PersMethods NodeIDInt TestData (StateT (TestLogState NodeIDInt TestData) m)
h = PersMethods
{ getCurrentTerm = gets (view #testLogStateCurrentTerm)
, setCurrentTerm = (#testLogStateCurrentTerm .=)
--
, getVotedFor = gets (view #testLogStateVotedFor)
, setVotedFor = (#testLogStateVotedFor .=)
--
, getLogEntry = \j -> gets $ Seq.lookup (j-1) . view #testLogStateLog
, setLogEntry = \j le -> #testLogStateLog %= \s -> do
when (Seq.length s < (j-1)) do
error "Raft algo error. Trying to set log element after missed elements"
Seq.take (j-1) s Seq.|> le
, getLogEntriesFrom = \j -> gets (F.toList . Seq.drop (j-1) . (view #testLogStateLog))
, getLastLogIndex = gets (Seq.length . view #testLogStateLog)
--
, getOurID = gets (view #testLogStateNodeID)
}
rstate <- gets (view #testLogStateRaftState)
(rstate', actions) <- do
flip runStateT mempty do
flip execStateT rstate do
flip runContT absurd do
actions :: [TestNodeAction] <- testNodeReact (hoistMethods (lift . lift) h) ev
lift . lift $ modify (actions <>)
-- lift . lift . modify . (<>) =<< testNodeReact (hoistMethods (lift . lift) h) ev
ContT \k -> pure ()
#testLogStateRaftState .= rstate'
pure (reverse actions)
where
seqLast :: Seq a -> a
seqLast = \case
(Seq.viewr -> _ Seq.:> x) -> x
_ -> error "no last element in empty sequence"
testNodeReact :: (MonadState (RaftState p) m, p ~ NodeIDInt, a ~ TestData)
=> PersMethods p a m -> NodeEvent p a -> ContT () m [TestNodeAction]
testNodeReact h ev = do
x <- nodeReact h ev =<< get
ContT \k -> do
case x of
ResetElectionTimer -> k [TestResetElectionTimer]
ResetLeaderHeartbeat -> k [TestResetLeaderHeartbeat]
UpdateState f -> id %= f
SwitchRole st -> do
#actorState .= st
k [TestLogMessage ("Switch role to " <> showt st)]
LogMessage msg -> k [TestLogMessage msg]
CallProc p proc -> k [TestCallProc p proc]
ReplyProc p proc -> k [TestReplyProc p proc]
ReplyToClientWhoIsLeader mp -> k [TestReplyToClientWhoIsLeader mp]
cix <- (gets (view #commitIndex))
(gets (view #lastAppliedIndex)) >>= fix \go lastApplied -> do
when (cix > lastApplied) do
-- increment lastApplied, apply log[lastApplied] to stateMachine
lastApplied' <- #lastAppliedIndex <%= succ
(getLogEntry h) lastApplied' >>= mapM_ \le -> do
case entryStateMachineCommand le of
SMCLoad a -> do
k [TestApplyLogEntryToSM a]
-- | SMAddNode p
-- | SMDropNode p
go lastApplied'
nodeReact :: forall m p a. (Monad m, Ord p, Show p, Show a)
=> PersMethods p a m
-> NodeEvent p a
-> RaftState p
-> ContT () m (NodeAction p a)
nodeReact h@PersMethods{..} ev RaftState{..} = do
ourID <- lift getOurID
let otherNodes = cluster `Set.difference` Set.singleton ourID
ContT \k -> case actorState of
StateFollower -> do
-- * respond to rpcs from candidates and leaders
-- * if election timeout elapses without receiving AppendEntries from
-- current leader or asking vote from candidates
-- then convert to candidate
case ev of
ElectionTimeoutElapses -> do
k (SwitchRole (StateCandidate (Set.singleton ourID)))
startNewElection k
LeaderHeartbeat -> do
pure ()
GotProcCall proc -> case proc of
CallRequestVote (req@RequestVote {..}) -> do
updateCurrentTerm_ k requestVoteTerm
granted <- replyAfterRequestVote req k
k (LogMessage $ "granted: " <> showt granted)
when granted do
k ResetElectionTimer
CallAppendEntries req@AppendEntries {..} -> do
updateCurrentTerm_ k appendEntriesTerm
replyAfterAppendEntries req k do
k ResetElectionTimer
RequestVoteReply {..} -> do
k (LogMessage "Follower Got RequestVoteReply. Why ???")
void $ updateCurrentTerm_ k requestVoteReplyTerm
AppendEntriesReply {..} -> do
void $ updateCurrentTerm_ k appendEntriesReplyTerm
GotClientCall {} -> do
votedFor <- getVotedFor
k (ReplyToClientWhoIsLeader votedFor)
-- * if votes received from majority of servers: become leader
-- * if AppendEntries received from new leader: become follower
-- * if election timeout elapses: start new election
StateCandidate{..} -> do
case ev of
ElectionTimeoutElapses -> do
startNewElection k
LeaderHeartbeat -> do
pure ()
GotProcCall proc -> case proc of
CallRequestVote req@RequestVote {..} -> do
upd <- updateCurrentTerm k requestVoteTerm
granted <- replyAfterRequestVote req k
when (granted && not upd) do
k ResetElectionTimer
CallAppendEntries req@AppendEntries {..} -> do
updateCurrentTerm_ k appendEntriesTerm
replyAfterAppendEntries req k do
k ResetElectionTimer
k (SwitchRole StateFollower)
RequestVoteReply {..} -> do
upd <- updateCurrentTerm k requestVoteReplyTerm
when (requestVoteReplyGranted && not upd) do
let votesCollected' = Set.insert requestVoteReplyFromID votesCollected
k (UpdateState (#actorState . _Ctor @"StateCandidate" .~ votesCollected'))
k (LogMessage ("Votes collected " <> showt votesCollected'))
when (Set.size votesCollected' > Set.size cluster `div` 2) do
(lastLogIndex, lastLogEntryTerm) <- getLastLogIndexNTerm h
k (SwitchRole (StateLeader
{ nextIndex = Map.fromList $ (Set.toList otherNodes) <&> (, succ lastLogIndex)
, matchIndex = Map.fromList $ (Set.toList otherNodes) <&> (, defMatchIndex)
}))
k ResetLeaderHeartbeat
forM_ otherNodes \p -> do
term <- getCurrentTerm
k (CallProc p (CallAppendEntries (
AppendEntries
{ appendEntriesTerm = term
, appendEntriesLeaderID = ourID
, appendEntriesPrevLogIndex = lastLogIndex
, appendEntriesPrevLogTerm = lastLogEntryTerm
, appendEntriesES = mempty
, appendEntriesLeaderCommitIndex = commitIndex
})))
AppendEntriesReply {..} -> do
void $ updateCurrentTerm k appendEntriesReplyTerm
GotClientCall {} -> do
votedFor <- getVotedFor
k (ReplyToClientWhoIsLeader votedFor)
StateLeader{..} -> do
let
leaderCallAppendEntries p = do
ourLastLogIndex <- getLastLogIndex
let pPrevIndex = maybe ourLastLogIndex pred (nextIndex ^? ix p)
(pPrevEntryTerm, entries') <-
if pPrevIndex > 0
then
maybe (error "Bug in algorithm") (over _1 entryTerm) . List.uncons
<$> getLogEntriesFrom pPrevIndex
else
(0 ,) <$> getLogEntriesFrom 1
term <- getCurrentTerm
k (CallProc p (CallAppendEntries (
AppendEntries
{ appendEntriesTerm = term
, appendEntriesLeaderID = ourID
, appendEntriesPrevLogIndex = pPrevIndex
, appendEntriesPrevLogTerm = pPrevEntryTerm
, appendEntriesES = entries'
, appendEntriesLeaderCommitIndex = commitIndex
})))
case ev of
ElectionTimeoutElapses ->
pure ()
LeaderHeartbeat -> do
mapM_ leaderCallAppendEntries otherNodes
k ResetLeaderHeartbeat
GotProcCall proc -> case proc of
CallRequestVote req@RequestVote {..} -> do
updateCurrentTerm k requestVoteTerm
replyAfterRequestVote req k
pure ()
CallAppendEntries req@AppendEntries {..} -> do
updateCurrentTerm k appendEntriesTerm
replyAfterAppendEntries req k do
k ResetElectionTimer
k (SwitchRole StateFollower)
pure ()
RequestVoteReply {..} -> do
updateCurrentTerm k requestVoteReplyTerm
pure ()
AppendEntriesReply {..} -> do
-- Нужно ли здесь учитывать appendEntriesReplyTerm ?
currentTerm <- getCurrentTerm
if (appendEntriesReplyTerm == currentTerm)
then do
if appendEntriesReplySuccess
then do
ourLastLogIndex <- getLastLogIndex
let
-- updMatchIndex :: Map p Int -> Map p Int
updMatchIndex = Lens.at appendEntriesReplyFromID . non defMatchIndex .~ ourLastLogIndex
k (UpdateState ((
#actorState . _Ctor @"StateLeader"
. _1 -- . #nextIndex
. ix appendEntriesReplyFromID .~ succ ourLastLogIndex
) . (
#actorState . _Ctor @"StateLeader"
. _2 -- . #matchIndex
%~ updMatchIndex
)))
let newCommitIndex = matchIndex & updMatchIndex & Map.elems
& Heap.fromList
& Heap.drop ((Set.size cluster `div` 2 - 1))
& Heap.uncons
& maybe defMatchIndex fst
when (newCommitIndex > commitIndex) do
getLogEntry newCommitIndex >>= mapM_ do
entryTerm >>> \term ->
when (term == currentTerm) do
setCurrentTerm term
k (UpdateState (#commitIndex .~ newCommitIndex))
else do
k (UpdateState (#actorState . _Ctor @"StateLeader"
. _1 -- . #nextIndex
. ix appendEntriesReplyFromID %~ pred
))
leaderCallAppendEntries appendEntriesReplyFromID
else
void $ updateCurrentTerm k appendEntriesReplyTerm
GotClientCall cmd -> do
j <- getLastLogIndex
term <- getCurrentTerm
setLogEntry (succ j)
(LogEntry
{ entryTerm = term
, entryStateMachineCommand = cmd
})
-- TODO "respond after entry applied to state machine"
where
defMatchIndex = 0
startNewElection k = do
ourID <- getOurID
let otherNodes = cluster `Set.difference` Set.singleton ourID
setCurrentTerm . succ =<< getCurrentTerm
setVotedFor . Just =<< getOurID
k ResetElectionTimer
term <- getCurrentTerm
(lastLogIndex, lastLogEntryTerm) <- getLastLogIndexNTerm h
forM_ otherNodes \p -> do
k (CallProc p (CallRequestVote (
RequestVote
{ requestVoteTerm = term
, requestVoteCandidateID = ourID
, requestVoteCandidateLastLogIndex = lastLogIndex
, requestVoteCandidateLastLogTerm = lastLogEntryTerm
})))
updateCurrentTerm_ k term = do
updateCurrentTerm' k term (pure ())
updateCurrentTerm k term = do
updateCurrentTerm' k term do
k (SwitchRole StateFollower)
k ResetElectionTimer
updateCurrentTerm' k term onUpdate = do
currentTerm <- getCurrentTerm
k (LogMessage ("updateCurrentTerm ? our:" <> showt currentTerm <> " -> new:" <> showt term))
if (currentTerm < term) then do
setCurrentTerm term
onUpdate
setVotedFor Nothing
pure True
else pure False
replyAfterRequestVote RequestVote {..} k = do
-- 1. if term < currentTerm: reply false
-- 2. else if voteFor is null or candidateID,
-- and candidate's log is at least up-to-date as our log: grant vote
currentTerm <- getCurrentTerm
granted <- (either (\e -> k (LogMessage e) >> pure False) (const (pure True))) =<< runExceptT do
when (requestVoteTerm < currentTerm) do
throwError "requestVoteTerm < currentTerm"
lift getVotedFor >>= mapM_ \ourVoteFor -> do
when (ourVoteFor /= requestVoteCandidateID) do
throwError "already voted for another candidate"
setVotedFor (Just requestVoteCandidateID)
ourID <- getOurID
k $ ReplyProc requestVoteCandidateID
$ RequestVoteReply
{ requestVoteReplyTerm = currentTerm
, requestVoteReplyGranted = granted
, requestVoteReplyFromID = ourID
}
pure granted
replyAfterAppendEntries AppendEntries {..} k onSuccess = do
-- 1. if term < currentTerm: reply false
-- 2. reply false if log doesn't contain an entry at prevLogIndex whose
-- term matches prevLogTerm
-- 3. if an existing entry conflicts with a new one (same index but
-- different terms), delete the existing entry and all that follow it
-- 4. append any new entries not already in the log
-- 5. if leaderCommit > commitIndex,
-- set commitIndex = min(leaderCommit, index of last new entry)
currentTerm <- getCurrentTerm
k (LogMessage ("replyAfterAppendEntries our:" <> showt currentTerm <> " <? new:" <> showt appendEntriesTerm))
success <- (either (\e -> k (LogMessage e) >> pure False) (const (pure True))) =<< runExceptT do
when (appendEntriesTerm < currentTerm) do
throwError "appendEntriesTerm < currentTerm"
when (appendEntriesPrevLogIndex > 0) do
le' <- justOrThrowError ("No log entry " <> showt appendEntriesPrevLogIndex)
$ getLogEntry appendEntriesPrevLogIndex
when (entryTerm le' /= appendEntriesPrevLogTerm) do
throwError "entryTerm at appendEntriesPrevLogIndex /= appendEntriesPrevLogTerm"
justOrThrowError "?-?" $ flip fix (zip [succ appendEntriesPrevLogIndex..] appendEntriesES) $
\go -> \case
[] -> pure (Just ())
(j, le):es ->
getLogEntry j >>= \case
Nothing -> do
setLogEntry j le
mapM_ (uncurry setLogEntry) es
pure (Just ())
Just cle -> do
if (entryTerm cle == entryTerm le)
then go es
else do
setLogEntry j le
mapM_ (uncurry setLogEntry) es
pure (Just ())
when (appendEntriesLeaderCommitIndex > commitIndex) do
lift do
j <- getLastLogIndex
k (UpdateState (#commitIndex .~ min appendEntriesLeaderCommitIndex j))
when success onSuccess
ourID <- getOurID
k $ ReplyProc appendEntriesLeaderID
$ AppendEntriesReply
{ appendEntriesReplyTerm = currentTerm
, appendEntriesReplySuccess = success
, appendEntriesReplyFromID = ourID
}
justOrThrowError :: Functor m => e -> m (Maybe a) -> ExceptT e m a
justOrThrowError e = ExceptT . fmap (maybe (Left e) Right)

244
examples/raft-algo/raft-algo.cabal Normal file
View File

@ -0,0 +1,244 @@
cabal-version: 3.0
name: raft-algo
version: 0.1.0.0
-- synopsis:
-- description:
license: BSD-3-Clause
license-file: LICENSE
-- author:
-- maintainer:
-- copyright:
category: Network
build-type: Simple
extra-doc-files: CHANGELOG.md
-- extra-source-files:
common warnings
ghc-options: -Wall
common common-deps
build-depends:
base, hbs2-core, hbs2-storage-simple
, async
, bytestring
, cache
, containers
, data-default
, deepseq
, directory
, filepath
, generic-lens
, hashable
, heaps
, microlens-platform
, mtl
, mwc-random
, prettyprinter
, QuickCheck
, random
, random-shuffle
, resourcet
, safe
, serialise
, split
, stm
, streaming
, suckless-conf
, tasty
, tasty-hunit
, temporary
, timeit
, transformers
, uniplate
, unordered-containers
, vector
, prettyprinter-ansi-terminal
, interpolatedstring-perl6
, unliftio
common shared-properties
ghc-options:
-Wall
-O2
-fno-warn-type-defaults
-- -fno-warn-unused-matches
-- -fno-warn-unused-do-bind
-- -Werror=missing-methods
-- -Werror=incomplete-patterns
-- -fno-warn-unused-binds
-threaded
-rtsopts
"-with-rtsopts=-N4 -A256m -AL256m -I0"
default-language: Haskell2010
default-extensions:
ApplicativeDo
, BangPatterns
, BlockArguments
, ConstraintKinds
, DataKinds
, DeriveDataTypeable
, DeriveGeneric
, DerivingStrategies
, DerivingVia
, ExtendedDefaultRules
, FlexibleContexts
, FlexibleInstances
, GADTs
, GeneralizedNewtypeDeriving
, ImportQualifiedPost
, LambdaCase
, MultiParamTypeClasses
, OverloadedLabels
, OverloadedStrings
, QuasiQuotes
, RankNTypes
, RecordWildCards
, ScopedTypeVariables
, StandaloneDeriving
, TupleSections
, TypeApplications
, TypeFamilies
, ViewPatterns
library
import: shared-properties
import: common-deps
default-language: Haskell2010
exposed-modules: RaftAlgo.Proto
ghc-options:
-- -prof
-- -fprof-auto
-- other-extensions:
-- type: exitcode-stdio-1.0
hs-source-dirs: lib
build-depends:
base, hbs2-core
, async
, attoparsec
, bytestring
, cache
, clock
, containers
, data-default
, directory
, hashable
, microlens-platform
, mtl
, mwc-random
, network
, network-ip
, optparse-applicative
, prettyprinter
, QuickCheck
, random
, safe
, serialise
, stm
, streaming
, tasty
, tasty-hunit
, text
, time
, transformers
, uniplate
, vector
, unliftio
executable raft-algo-app
import: shared-properties
import: common-deps
default-language: Haskell2010
ghc-options:
-- -prof
-- -fprof-auto
-- other-modules:
-- other-extensions:
-- type: exitcode-stdio-1.0
hs-source-dirs: app lib
main-is: RaftAlgoMain.hs
build-depends:
base, raft-algo, hbs2-core, hbs2-storage-simple
, async
, attoparsec
, bytestring
, cache
, clock
, containers
, data-default
, data-textual
, directory
, hashable
, microlens-platform
, mtl
, mwc-random
, network
, network-ip
, optparse-applicative
, prettyprinter
, QuickCheck
, random
, safe
, serialise
, stm
, streaming
, tasty
, tasty-hunit
, text
, time
, transformers
, uniplate
, vector
, unliftio
test-suite raft-algo-proto-test
import: shared-properties
default-language: Haskell2010
other-modules:
type: exitcode-stdio-1.0
hs-source-dirs: test
main-is: RaftAlgoProtoTest.hs
build-depends:
base, raft-algo, hbs2-core
, async
, bytestring
, cache
, cborg
, containers
, directory
, filepath
, hashable
, microlens-platform
, mtl
, optparse-applicative
, prettyprinter
, QuickCheck
, random
, safe
, serialise
, tasty
, tasty-hunit
, temporary
, timeit
, uniplate
, unliftio
, unordered-containers
, vector

33
examples/raft-algo/test/RaftAlgoProtoTest.hs Normal file
View File

@ -0,0 +1,33 @@
module Main where
import HBS2.Prelude.Plated
import HBS2.System.Logger.Simple
import HBS2.Clock
import HBS2.Hash
import HBS2.Base58
import RaftAlgo.Proto
import Data.Ord
import Data.Functor
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.List qualified as List
import Control.Monad.Reader
import System.Random
import Data.Hashable hiding (Hashed)
import Data.Word
import Lens.Micro.Platform
import Data.Fixed
import Options.Applicative as O
import Data.Cache (Cache)
import Data.Cache qualified as Cache
import Data.Maybe
import Data.Graph
import Data.HashSet (HashSet)
import Data.HashSet qualified as HashSet
import Codec.Serialise
import UnliftIO

11
hbs2-core/hbs2-core.cabal
View File

@ -20,6 +20,7 @@ common shared-properties
ghc-options:
-Wall
-fno-warn-type-defaults
-- -fprint-potential-instances
-- -prof -fprof-auto
-- -fno-warn-unused-matches
-- -fno-warn-unused-do-bind
@ -40,6 +41,7 @@ common shared-properties
, ConstraintKinds
, DataKinds
, DeriveDataTypeable
, DeriveFunctor
, DeriveGeneric
, DerivingStrategies
, DerivingVia
@ -121,10 +123,10 @@ library
, HBS2.Storage.Operations
, HBS2.System.Logger.Simple
, HBS2.System.Logger.Simple.Class
, Dialog.Core
, Dialog.Client
, Dialog.Helpers.List
, Dialog.Helpers.Streaming
, HBS2.Net.Dialog.Core
, HBS2.Net.Dialog.Client
, HBS2.Net.Dialog.Helpers.List
, HBS2.Net.Dialog.Helpers.Streaming
-- other-modules:
@ -140,6 +142,7 @@ library
, cache
, cborg
, clock
, constraints
, containers
, cryptonite
, data-default

442
hbs2-core/lib/Dialog/Core.hs
View File

@ -1,442 +0,0 @@
{-# LANGUAGE StrictData #-}
-- {-# LANGUAGE OverloadedLists #-}
-- {-# LANGUAGE UndecidableInstances #-}
module Dialog.Core where
-- import Data.ByteString.Builder as Builder
-- import Data.ByteString.Builder.Internal as Builder
-- import GHC.IsList
import Codec.Serialise
import Control.Arrow
import Control.Monad
import Control.Monad.Error.Class
import Control.Monad.Except (Except(..), ExceptT(..), runExcept, runExceptT)
import Control.Monad.IO.Class
import Control.Monad.State.Class as State
import Control.Monad.State.Strict (evalStateT)
import Control.Monad.Trans.Class
import Control.Monad.Writer qualified as W
import Data.Binary.Get as Get
import Data.Binary.Put as Put
import Data.Bits
import Data.Bool
import Data.ByteArray (ByteArrayAccess)
import Data.ByteArray.Sized as BAS
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Lazy qualified as BSL
import Data.Foldable
import Data.Foldable as F
import Data.Function
import Data.Generics.Labels
import Data.Generics.Product.Fields
import Data.List qualified as List
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict as Map
import Data.Maybe
import Data.String.Conversions as X (cs)
import Data.Text (Text)
import Data.Word
import GHC.Exts
import GHC.Generics (Generic)
import Lens.Micro.Platform
import Numeric.Natural
import System.Random.MWC
import UnliftIO.Exception
import UnliftIO.STM
-- import Prettyprinter
-- import HBS2.Base58
import Data.ByteString.Base16 qualified as B16
import Dialog.Helpers.List
type Frames = Frames' ByteString
newtype Frames' a = Frames { unFrames :: [a] }
deriving stock (Generic,Eq)
deriving newtype (Functor, Foldable, Semigroup, Monoid
-- , IsList
)
instance Show Frames where
show (Frames xs) = "Frames " <> show (BS.length <$> xs)
-- <> " " <> show (fmap B16.encode xs)
<> " " <> (show . fmap (limitSize 42)) xs
where
limitSize n as = bool as (BS.take (n-3) as <> "...") (BS.length as > n)
framesBodyPart :: Traversal' Frames [ByteString]
framesBodyPart = #unFrames . tailAfterP (== "")
tailAfterP :: forall a . (a -> Bool) -> Traversal' [a] [a]
tailAfterP p focus = fix \go -> \case
x:xs -> (x :) <$> bool go focus (p x) xs
xs -> pure xs
---
-- encodeFrames :: Frames -> ByteString
encodeFrames :: Foldable t => t ByteString -> ByteString
encodeFrames = F.toList >>> BSL.toStrict . runPut . \case
[] -> pure ()
xss -> flip fix xss \go -> \case
[] -> pure ()
bs:xs -> do
let (flip shiftR 1 -> n1, ns) = unfoldSizeBytes @Word64 . flip shiftL 1 . fromIntegral . BS.length $ bs
putWord8 $ n1
& (bool (sbit 7) id (List.null xs))
& (bool (sbit 6) id (List.null ns))
forM_ (markMore ns) \(n, isMoreBytesInSize) -> do
putWord8 $ n & bool (zbit 7) (sbit 7) isMoreBytesInSize
putByteString bs
go xs
where
markMore as = zip as ((True <$ List.drop 1 as) <> [False])
unfoldSizeBytes :: (Bits n, Integral n) => n -> (Word8, [Word8])
unfoldSizeBytes = (\(a NE.:| as) -> (a, as)) . NE.unfoldr \w ->
( (flip shiftR 1 . flip shiftL 1 . fromIntegral) w
, let w' = shiftR w 7
in bool Nothing (Just w') (w' > 0)
)
decodeFrames :: MonadError String m => ByteString -> m Frames
decodeFrames = \case
"" -> pure mempty
bs' -> (bs' &) $ BSL.fromStrict >>> either (throwError . view _3) (pure . Frames . view _3)
<$> runGetOrFail do
fix \go -> do
j <- getWord8
size <-
flip fix (6, j) \fu (b, j') -> do
let n = (fromIntegral . clearLeftBits (8-b)) j'
if (tbit b j')
then (n +) . flip shiftL b <$> (fu . (7, ) =<< getWord8)
else pure n
bs <- getByteString size
let moreFrames = tbit 7 j
if moreFrames
then (bs :) <$> go
else pure [bs]
where
clearLeftBits n = flip shiftR n . flip shiftL n
tbit = flip testBit
devDialogCore :: IO ()
devDialogCore = do
display (Frames [])
display (Frames [""])
display (Frames [BS.replicate 32 0x55])
display (Frames [BS.replicate 32 0x55, ""])
display (Frames [BS.replicate 32 0x55, "\3\3"])
display (Frames [BS.replicate 33 0x55, "\3\3"])
display (Frames [BS.replicate 63 0x55])
display (Frames [BS.replicate 64 0x55])
-- display (Frames [BS.replicate 65 0x55])
display (Frames ["\8\8\8","\4\4\4"])
display (Frames ["","\1"])
where
display a = do
putStrLn . cs . show . B16.encode . encodeFrames $ a
putStrLn ""
sbit :: (Bits n) => Int -> n -> n
sbit = flip setBit
zbit :: (Bits n) => Int -> n -> n
zbit = flip clearBit
---
decodeFramesFail :: (MonadFail m) => ByteString -> m Frames
decodeFramesFail = errorToFail . decodeFrames
---
errorToFailT :: (MonadFail m) => ExceptT String m a -> m a
errorToFailT = either fail pure <=< runExceptT
errorToFail :: MonadFail m => Except String a -> m a
errorToFail = either fail pure . runExcept
errorShowToFail :: (MonadFail m, Show s) => Except s a -> m a
errorShowToFail = either (fail . show) pure . runExcept
--
data CallerID = CallerID
{ unCallerIDV :: Word8
, unCallerID :: Word32
}
deriving stock (Generic, Eq, Ord)
instance Serialise CallerID
newCallerID :: forall m. MonadIO m => m CallerID
newCallerID = liftIO $ withSystemRandomST \g ->
CallerID <$> (uniformM g) <*> (uniformM g)
---
newtype CallerHandler m = CallerHandler
{ unCallerHandler :: Frames -> m ()
}
newtype CallerEnv m = CallerEnv
{ unCallerEnv :: TVar (Map CallerID (CallerHandler m)) }
newCallerEnv :: MonadIO m => m (CallerEnv m')
newCallerEnv = CallerEnv <$> newTVarIO mempty
---
newtype RequestResponseHandler m = RequestResponseHandler
{ unRequestResponseHandler :: Frames -> m ()
}
newtype RequestResponseEnv m = RequestResponseEnv
{ unRequestResponseEnv :: TVar (Map RequestID (RequestResponseHandler m))
}
newRequestResponseEnv :: MonadIO m => m (RequestResponseEnv m')
newRequestResponseEnv =
RequestResponseEnv <$> newTVarIO mempty
---
data DClient m p i = DClient
{ clientCallerEnv :: CallerEnv m
, clientSendProtoRequest :: p -> Frames -> m ()
, clientGetKnownPeers :: m [(p, i)]
}
---
newtype RequestID = RequestID { unRequestID :: Word32 }
deriving stock (Generic, Eq, Ord)
deriving newtype (Serialise, Num, Enum)
-- deriving via TODO_GenericVLQ Put Get
data RequestResult
= RequestDone
-- | RequestSuccessIncomplete
| RequestTimeout
| RequestFailure ResponseStatusCode Frames
| RequestErrorBadResponse BadResponse Frames
deriving stock (Generic, Eq, Show)
data BadResponse
= ResponseErrorNoResponseHeader
| ResponseInsufficientFrames
| ResponseParseError DeserialiseFailure
deriving stock (Generic, Eq, Show)
---
setupCallerEnv :: MonadIO m => CallerEnv m' -> CallerID -> CallerHandler m' -> m ()
setupCallerEnv env callerID repHandleEnv =
(atomically . modifyTVar' (unCallerEnv env))
(at callerID .~ Just repHandleEnv)
clearCallerEnv :: MonadIO m => CallerEnv m' -> CallerID -> m ()
clearCallerEnv env callerID =
(atomically . modifyTVar' (unCallerEnv env))
(at callerID .~ Nothing)
findCallerHandler :: MonadIO m => CallerEnv m' -> CallerID -> m (Maybe (CallerHandler m'))
findCallerHandler CallerEnv{..} callerID =
(atomically (readTVar unCallerEnv)) <&> (preview (ix callerID))
---
setupRepHandler :: MonadIO m => RequestResponseEnv m' -> RequestID -> RequestResponseHandler m' -> m ()
setupRepHandler RequestResponseEnv{..} requestID useResponse =
(atomically . modifyTVar' unRequestResponseEnv)
(at requestID .~ Just useResponse)
clearRepHandler :: MonadIO m => RequestResponseEnv m' -> RequestID -> m ()
clearRepHandler RequestResponseEnv{..} requestID =
(atomically . modifyTVar' unRequestResponseEnv)
(at requestID .~ Nothing)
findRepHandler :: MonadIO m => RequestResponseEnv m' -> RequestID -> m (Maybe (RequestResponseHandler m'))
findRepHandler RequestResponseEnv{..} requestID =
(atomically (readTVar unRequestResponseEnv)) <&> (preview (ix requestID))
---
data DialogRequestEnv m p pd = DialogRequestEnv
{ dreqEnvPeer :: p
, dreqEnvGetPeerData :: m pd
}
-- data DialogRequestError
-- = DialogRequestFailure String
-- deriving stock (Show)
-- instance Exception DialogRequestError
---
newtype DialogRequestRouter m = DialogRequestRouter
{ unDialogRequestRouter ::
Map [ByteString] -- path
-- handler :: Input -> m (Either ErrorMessage (HowToReply -> ResponseContinuation))
(Frames -> Either Text ((Frames -> m ()) -> m ()))
}
deriving (Semigroup, Monoid)
dialogRequestRoutes
:: ListBuilder
([ByteString], Frames -> Either Text ((Frames -> m ()) -> m ()))
-> DialogRequestRouter m
dialogRequestRoutes = DialogRequestRouter . Map.fromList . buildList
hand :: Monad m => a -> b -> ListBuilderT m (a, b)
hand = curry li
---
dpath :: Text -> [ByteString] -> Frames
dpath path = Frames . (cs path :)
---
addEnvelope :: Monoid a => [a] -> Frames' a -> Frames' a
addEnvelope en = over #unFrames ((en <> [mempty]) <>)
splitEnvelope :: (Monoid a, Eq a) => Frames' a -> ([a], Frames' a)
splitEnvelope = fmap (Frames . List.drop 1) . List.break (== mempty) . unFrames
data ResponseHeader = ResponseHeader
{ respStatus :: ResponseStatus
, respSeqNumber :: Int
}
deriving (Generic, Show, Eq)
instance Serialise ResponseHeader
data ResponseStatus = ResponseStatus
{ responseStatusCode :: ResponseStatusCode
, responseStatusMessage :: Text
}
deriving (Generic, Show, Eq)
instance Serialise ResponseStatus
data ResponseStatusCode
= Success200
| SuccessMore
| BadRequest400
| Forbidden403
| NotFound404
deriving (Generic, Show, Eq)
instance Serialise ResponseStatusCode
routerSignature :: Word8
routerSignature = 1
routeDialogRequest :: forall m p pd .
Monad m
=> DialogRequestRouter m
-> DialogRequestEnv m p pd
-> (Frames -> m ())
-> Frames
-> m ()
routeDialogRequest router drenv rawReplyToPeer frames = do
erun <- pure $ runExcept $ flip evalStateT req do
signature <- cutFrameDecode
(ResponseStatus BadRequest400 "No signature in request")
when (signature /= routerSignature) $ throwError
(ResponseStatus BadRequest400 "Wrong signature in request")
route <- cutFrameOr
(ResponseStatus BadRequest400 "No route in request")
h <- fromJustThrowError
(ResponseStatus NotFound404 "Route not found")
(unDialogRequestRouter router ^? ix (BS8.split '/' route))
lift . ExceptT . pure
-- Если не может разобрать параметры запроса,
-- то самим ответить этому пиру '404'
. left (ResponseStatus BadRequest400)
. h
-- передать оставшуюся часть запроса в хэндлер
=<< get
case erun of
Left rs -> replyToPeer (Frames [serialiseS (ResponseHeader rs 0)])
Right run ->
-- передать хэндлеру продолжение чтобы ответить этому пиру
run replyToPeer
where
(backPath, req) = splitEnvelope frames
replyToPeer :: Frames -> m ()
replyToPeer = rawReplyToPeer . over #unFrames (backPath <>)
cutFrameDecode :: (Serialise b, MonadState Frames m, MonadError e m) => e -> m b
cutFrameDecode e =
State.gets unFrames >>= \case
x:xs ->
(either (const (throwError e)) pure . deserialiseOrFailS) x
<* State.put (Frames xs)
_ -> throwError e
cutFrameDecode'
:: (Serialise b, MonadState Frames m, MonadError (Maybe DeserialiseFailure) m)
=> m b
cutFrameDecode' =
State.gets unFrames >>= \case
x:xs ->
(either (throwError . Just) pure . deserialiseOrFailS) x
<* State.put (Frames xs)
_ -> throwError Nothing
cutFrameOr :: (MonadState (Frames' b) m, MonadError e m) => e -> m b
cutFrameOr e =
State.gets unFrames >>= \case
x:xs -> x <$ State.put (Frames xs)
_ -> throwError e
serialiseS :: Serialise a => a -> ByteString
serialiseS = BSL.toStrict . serialise
deserialiseOrFailS :: Serialise a => ByteString -> Either DeserialiseFailure a
deserialiseOrFailS = deserialiseOrFail . BSL.fromStrict
fromMaybeM :: Applicative m => m a -> Maybe a -> m a
fromMaybeM ma = maybe ma pure
fromJustThrowError :: MonadError e m => e -> Maybe a -> m a
fromJustThrowError = fromMaybeM . throwError

32
hbs2-core/lib/HBS2/Actors/Peer.hs
View File

@ -11,6 +11,7 @@ module HBS2.Actors.Peer
import HBS2.Actors
import HBS2.Actors.Peer.Types
import HBS2.Clock
import HBS2.Data.Types.Crypto
import HBS2.Data.Types.Peer
import HBS2.Defaults
import HBS2.Events
@ -158,30 +159,8 @@ data PeerEnv e =
, _envSweepers :: TVar (HashMap SKey [PeerM e IO ()])
, _envReqMsgLimit :: Cache (Peer e, Integer, Encoded e) ()
, _envReqProtoLimit :: Cache (Peer e, Integer) ()
, _envAsymmetricKeyPair :: AsymmKeypair (Encryption e)
, _envEncryptionKeys :: TVar (HashMap (PeerData e) (CommonSecret (Encryption e)))
}
setEncryptionKey ::
( Hashable (PubKey 'Sign (Encryption L4Proto))
, Hashable PeerNonce
, Show (PubKey 'Sign (Encryption L4Proto))
, Show PeerNonce
, Show (CommonSecret (Encryption L4Proto))
) => PeerEnv L4Proto -> Peer L4Proto -> PeerData L4Proto -> Maybe (CommonSecret (Encryption L4Proto)) -> IO ()
setEncryptionKey penv peer pd msecret = do
atomically $ modifyTVar' (_envEncryptionKeys penv) $ Lens.at pd .~ msecret
case msecret of
Nothing -> trace $ "ENCRYPTION delete key" <+> pretty peer <+> viaShow pd
Just k -> trace $ "ENCRYPTION store key" <+> pretty peer <+> viaShow pd <+> viaShow k
getEncryptionKey ::
( Hashable (PubKey 'Sign (Encryption L4Proto))
, Hashable PeerNonce
) => PeerEnv L4Proto -> PeerData L4Proto -> IO (Maybe (CommonSecret (Encryption L4Proto)))
getEncryptionKey penv pd =
readTVarIO (_envEncryptionKeys penv) <&> preview (Lens.ix pd)
newtype PeerM e m a = PeerM { fromPeerM :: ReaderT (PeerEnv e) m a }
deriving newtype ( Functor
, Applicative
@ -189,6 +168,7 @@ newtype PeerM e m a = PeerM { fromPeerM :: ReaderT (PeerEnv e) m a }
, MonadReader (PeerEnv e)
, MonadIO
, MonadUnliftIO
, MonadTrans
)
@ -212,10 +192,10 @@ makeLenses 'PeerEnv
makeLenses 'ResponseEnv
runResponseM :: forall e m . (Monad m)
runResponseM :: forall e m a . (Monad m)
=> Peer e
-> ResponseM e m ()
-> m ()
-> ResponseM e m a
-> m a
runResponseM peer f = runReaderT (fromResponse f) (ResponseEnv peer)
@ -434,8 +414,6 @@ newPeerEnv s bus p = do
_envSweepers <- liftIO (newTVarIO mempty)
_envReqMsgLimit <- liftIO (Cache.newCache (Just defRequestLimit))
_envReqProtoLimit <- liftIO (Cache.newCache (Just defRequestLimit))
_envAsymmetricKeyPair <- asymmNewKeypair @(Encryption e)
_envEncryptionKeys <- liftIO (newTVarIO mempty)
pure PeerEnv {..}
runPeerM :: forall e m . ( MonadIO m

2
hbs2-core/lib/HBS2/Data/Types/Refs.hs
View File

@ -8,7 +8,7 @@ module HBS2.Data.Types.Refs
import HBS2.Base58
import HBS2.Hash
import HBS2.Merkle
import HBS2.Net.Proto.Types (Encryption)
import HBS2.Net.Proto.Types
import HBS2.Net.Auth.Credentials
import HBS2.Prelude

1
hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs
View File

@ -10,6 +10,7 @@ import HBS2.Data.Types
import HBS2.Merkle
import HBS2.Net.Auth.Credentials
import HBS2.Net.Proto.Definition
import HBS2.Net.Proto.Types
import HBS2.Prelude.Plated
import Codec.Serialise

6
hbs2-core/lib/HBS2/Net/Auth/Credentials.hs
View File

@ -28,11 +28,6 @@ import Data.Kind
type family EncryptPubKey e :: Type
data CryptoAction = Sign | Encrypt
type family PubKey ( a :: CryptoAction) e :: Type
type family PrivKey ( a :: CryptoAction) e :: Type
class Signatures e where
type family Signature e :: Type
makeSign :: PrivKey 'Sign e -> ByteString -> Signature e
@ -207,4 +202,3 @@ instance IsEncoding (PubKey 'Encrypt e)
=> Pretty (KeyringEntry e) where
pretty ke = fill 10 "pub-key:" <+> pretty (AsBase58 (Crypto.encode (view krPk ke)))

13
hbs2-core/lib/Dialog/Client.hs → hbs2-core/lib/HBS2/Net/Dialog/Client.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE ImpredicativeTypes #-}
module Dialog.Client where
module HBS2.Net.Dialog.Client where
-- import System.Clock
-- import System.Timeout
@ -34,8 +34,8 @@ import UnliftIO.Exception
import UnliftIO.STM
import UnliftIO.Timeout
import Dialog.Core
import Dialog.Helpers.Streaming
import HBS2.Net.Dialog.Core
import HBS2.Net.Dialog.Helpers.Streaming
---
@ -96,10 +96,11 @@ dQuery' par dcli peer rq go =
processResponseHeader rhxs@(rh, xs) = case ((responseStatusCode . respStatus) rh) of
Success200 -> Left (Just rhxs, RequestDone)
SuccessNoContent204 -> Left (Just rhxs, RequestDone)
SuccessMore -> Right rhxs
r@BadRequest400 -> Left (Nothing, (RequestFailure r xs))
r@Forbidden403 -> Left (Nothing, (RequestFailure r xs))
r@NotFound404 -> Left (Nothing, (RequestFailure r xs))
BadRequest400 -> Left (Nothing, (RequestFailure (respStatus rh) xs))
Forbidden403 -> Left (Nothing, (RequestFailure (respStatus rh) xs))
NotFound404 -> Left (Nothing, (RequestFailure (respStatus rh) xs))
rq' = rq & #unFrames %~ ([serialiseS routerSignature] <>)

831
hbs2-core/lib/HBS2/Net/Dialog/Core.hs Normal file
View File

@ -0,0 +1,831 @@
{-# Language AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- {-# LANGUAGE ConstraintKinds #-}
-- {-# LANGUAGE OverloadedLists #-}
-- {-# LANGUAGE CPP #-}
-- {-# LANGUAGE DataKinds #-}
-- {-# LANGUAGE FlexibleContexts #-}
-- {-# LANGUAGE FlexibleInstances #-}
-- {-# LANGUAGE MultiParamTypeClasses #-}
-- {-# LANGUAGE OverloadedStrings #-}
-- {-# LANGUAGE RankNTypes #-}
-- {-# LANGUAGE ScopedTypeVariables #-}
-- {-# LANGUAGE TupleSections #-}
-- {-# LANGUAGE TypeApplications #-}
-- {-# LANGUAGE TypeFamilies #-}
module HBS2.Net.Dialog.Core where
import Codec.Serialise
import Control.Arrow
import Control.Monad
import Control.Monad.Error.Class
import Control.Monad.Except (Except, ExceptT(..), runExcept, runExceptT)
import Control.Monad.IO.Class
import Control.Monad.State.Class as State
import Control.Monad.State.Strict as StateStrict (evalState, evalStateT, runStateT, StateT(..))
import Control.Monad.Trans.Class
import Data.Binary.Get as Get
import Data.Binary.Put as Put
import Data.Bits
import Data.Bool
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Base16 qualified as B16
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Lazy qualified as BSL
import Data.Constraint (Dict(..))
import Data.Foldable as F
import Data.Function
import Data.Functor
import Data.Generics.Labels ()
import Data.Generics.Product.Fields ()
import Data.Generics.Sum.Constructors
import Data.Kind
import Data.List qualified as List
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict as Map
import Data.Maybe
import Data.Proxy
import Data.String.Conversions as X (cs)
import Data.Text (Text)
import Data.Typeable
import Data.Word
import GHC.Generics ((:*:) (..), Generic (..), K1 (..), M1 (..))
import GHC.Generics qualified as Generics
import GHC.TypeLits
import Lens.Micro.Platform
import Streaming
import System.Random.MWC
import UnliftIO.STM
import HBS2.Net.Dialog.Helpers.List
type Frames = Frames' ByteString
newtype Frames' a = Frames { unFrames :: [a] }
deriving stock (Generic,Eq)
deriving newtype (Functor, Foldable, Semigroup, Monoid
-- , IsList
)
instance Show Frames where
show (Frames xs) = "Frames " <> show (BS.length <$> xs)
-- <> " " <> show (fmap B16.encode xs)
<> " " <> (show . fmap (limitSize 42)) xs
where
limitSize n as = bool as (BS.take (n-3) as <> "...") (BS.length as > n)
framesBodyPart :: Traversal' Frames [ByteString]
framesBodyPart = #unFrames . tailAfterP (== "")
tailAfterP :: forall a . (a -> Bool) -> Traversal' [a] [a]
tailAfterP p focus = fix \go -> \case
x:xs -> (x :) <$> bool go focus (p x) xs
xs -> pure xs
---
encodeFrames :: Frames -> ByteString
-- encodeFrames :: Foldable t => t ByteString -> ByteString
encodeFrames = F.toList >>> BSL.toStrict . runPut . \case
[] -> pure ()
xss -> flip fix xss \go -> \case
[] -> pure ()
bs:xs -> do
let (flip shiftR 1 -> n1, ns) = unfoldSizeBytes @Word64 . flip shiftL 1 . fromIntegral . BS.length $ bs
putWord8 $ n1
& bool (sbit 7) id (List.null xs)
& bool (sbit 6) id (List.null ns)
forM_ (markMore ns) \(n, isMoreBytesInSize) -> do
putWord8 $ n & bool (zbit 7) (sbit 7) isMoreBytesInSize
putByteString bs
go xs
where
markMore as = zip as ((True <$ List.drop 1 as) <> [False])
unfoldSizeBytes :: (Bits n, Integral n) => n -> (Word8, [Word8])
unfoldSizeBytes = (\(a NE.:| as) -> (a, as)) . NE.unfoldr \w ->
( (flip shiftR 1 . flip shiftL 1 . fromIntegral) w
, let w' = shiftR w 7
in bool Nothing (Just w') (w' > 0)
)
decodeFrames :: MonadError String m => ByteString -> m Frames
decodeFrames = \case
"" -> pure mempty
bs' -> (bs' &) $ BSL.fromStrict >>> either (throwError . view _3) (pure . Frames . view _3)
<$> runGetOrFail do
fix \go -> do
j <- getWord8
bsize <-
flip fix (6, j) \fu (b, j') -> do
let n = (fromIntegral . clearLeftBits (8-b)) j'
if tbit b j'
then (n +) . flip shiftL b <$> (fu . (7, ) =<< getWord8)
else pure n
bs <- getByteString bsize
let moreFrames = tbit 7 j
if moreFrames
then (bs :) <$> go
else pure [bs]
where
clearLeftBits n = flip shiftR n . flip shiftL n
tbit = flip testBit
devDialogCore :: IO ()
devDialogCore = do
display (Frames [])
display (Frames [""])
display (Frames [BS.replicate 32 0x55])
display (Frames [BS.replicate 32 0x55, ""])
display (Frames [BS.replicate 32 0x55, "\3\3"])
display (Frames [BS.replicate 33 0x55, "\3\3"])
display (Frames [BS.replicate 63 0x55])
display (Frames [BS.replicate 64 0x55])
-- display (Frames [BS.replicate 65 0x55])
display (Frames ["\8\8\8","\4\4\4"])
display (Frames ["","\1"])
where
display a = do
putStrLn . cs . show . B16.encode . encodeFrames $ a
putStrLn ""
sbit :: (Bits n) => Int -> n -> n
sbit = flip setBit
zbit :: (Bits n) => Int -> n -> n
zbit = flip clearBit
---
decodeFramesFail :: (MonadFail m) => ByteString -> m Frames
decodeFramesFail = errorToFail . decodeFrames
---
errorToFailT :: (MonadFail m) => ExceptT String m a -> m a
errorToFailT = either fail pure <=< runExceptT
errorToFail :: MonadFail m => Except String a -> m a
errorToFail = either fail pure . runExcept
errorShowToFail :: (MonadFail m, Show s) => Except s a -> m a
errorShowToFail = either (fail . show) pure . runExcept
--
data CallerID = CallerID
{ unCallerIDV :: Word8
, unCallerID :: Word32
}
deriving stock (Generic, Eq, Ord)
instance Serialise CallerID
newCallerID :: forall m. MonadIO m => m CallerID
newCallerID = liftIO $ withSystemRandomST \g ->
CallerID <$> uniformM g <*> uniformM g
---
newtype CallerHandler m = CallerHandler
{ unCallerHandler :: Frames -> m ()
}
newtype CallerEnv m = CallerEnv
{ unCallerEnv :: TVar (Map CallerID (CallerHandler m)) }
newCallerEnv :: MonadIO m => m (CallerEnv m')
newCallerEnv = CallerEnv <$> newTVarIO mempty
---
newtype RequestResponseHandler m = RequestResponseHandler
{ unRequestResponseHandler :: Frames -> m ()
}
newtype RequestResponseEnv m = RequestResponseEnv
{ unRequestResponseEnv :: TVar (Map RequestID (RequestResponseHandler m))
}
newRequestResponseEnv :: MonadIO m => m (RequestResponseEnv m')
newRequestResponseEnv =
RequestResponseEnv <$> newTVarIO mempty
---
data DClient m p i = DClient
{ clientCallerEnv :: CallerEnv m
, clientSendProtoRequest :: p -> Frames -> m ()
, clientGetKnownPeers :: m [(p, i)]
}
---
newtype RequestID = RequestID { unRequestID :: Word32 }
deriving stock (Generic, Eq, Ord)
deriving newtype (Serialise, Num, Enum)
-- deriving via TODO_GenericVLQ Put Get
data RequestResult
= RequestDone
-- | RequestSuccessIncomplete
| RequestTimeout
| RequestFailure ResponseStatus Frames
| RequestErrorBadResponse BadResponse Frames
deriving stock (Generic, Eq, Show)
data BadResponse
= ResponseErrorNoResponseHeader
| ResponseInsufficientFrames
| ResponseParseError DeserialiseFailure
deriving stock (Generic, Eq, Show)
---
setupCallerEnv :: MonadIO m => CallerEnv m' -> CallerID -> CallerHandler m' -> m ()
setupCallerEnv env callerID repHandleEnv =
(atomically . modifyTVar' (unCallerEnv env))
(at callerID ?~ repHandleEnv)
clearCallerEnv :: MonadIO m => CallerEnv m' -> CallerID -> m ()
clearCallerEnv env callerID =
(atomically . modifyTVar' (unCallerEnv env))
(at callerID .~ Nothing)
findCallerHandler :: MonadIO m => CallerEnv m' -> CallerID -> m (Maybe (CallerHandler m'))
findCallerHandler CallerEnv{..} callerID =
readTVarIO unCallerEnv <&> preview (ix callerID)
---
setupRepHandler :: MonadIO m => RequestResponseEnv m' -> RequestID -> RequestResponseHandler m' -> m ()
setupRepHandler RequestResponseEnv{..} requestID useResponse =
(atomically . modifyTVar' unRequestResponseEnv)
(at requestID ?~ useResponse)
clearRepHandler :: MonadIO m => RequestResponseEnv m' -> RequestID -> m ()
clearRepHandler RequestResponseEnv{..} requestID =
(atomically . modifyTVar' unRequestResponseEnv)
(at requestID .~ Nothing)
findRepHandler :: MonadIO m => RequestResponseEnv m' -> RequestID -> m (Maybe (RequestResponseHandler m'))
findRepHandler RequestResponseEnv{..} requestID =
readTVarIO unRequestResponseEnv <&> preview (ix requestID)
---
data DialogRequestEnv m p pd = DialogRequestEnv
{ dreqEnvPeer :: p
, dreqEnvGetPeerData :: m pd
}
-- data DialogRequestError
-- = DialogRequestFailure String
-- deriving stock (Show)
-- instance Exception DialogRequestError
---
-- type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
type DApp m = Frames -> (Frames -> m ()) -> m ()
mkDApp ::
forall spec ctx m io.
( Monad m
, Monad io
, HasHandler m (NamedSpec spec) ctx
, HasHandler io (NamedSpec spec) ctx
)
=> Proxy (NamedSpec spec)
-> Ctx ctx
-> (forall x. m x -> DialHandlerT io x)
-> spec (ModeServerT m)
-> DApp io
mkDApp p ctx ntToDialHandlerTn hd = routeDialogRequest rr
where
rr :: DialogRequestRouter io
rr = route p ctx
$ hoistDialogWithContext p (Proxy @ctx) ntToDialHandlerTn
hd
type DialogReplyHandler m = (Frames -> m ()) -> m ()
type DialogRequestRouter (m :: Type -> Type) =
DialogRequestRoutes (DialogReplyHandler m)
data DialogRequestRoutes (h :: Type)
= DialogRequestPaths (Map ByteString (DialogRequestRoutes h))
| DialogRequestPreparse (Frames -> Either Text (DialogRequestRoutes h, Frames))
| DialogRequestEndpoint h
deriving (Generic, Functor)
instance Semigroup (DialogRequestRoutes h) where
(<>) a b = case (a, b) of
(DialogRequestPaths p1, DialogRequestPaths p2) ->
DialogRequestPaths (p1 <> p2)
_ -> b
-- instance Monoid (DialogRequestRoutes h) where
-- mempty = DialogRequestPaths mempty
dialogRequestRoutes
:: ListBuilder
([ByteString], Frames -> Either Text ((Frames -> m ()) -> m (), Frames))
-> DialogRequestRouter m
dialogRequestRoutes = List.foldl1' (<>)
. fmap toPaths
. over (traverse . _2) (DialogRequestPreparse . (fmap . fmap) (over _1 DialogRequestEndpoint))
. buildList
where
toPaths :: ([ByteString], DialogRequestRoutes ((Frames -> m ()) -> m ()))
-> DialogRequestRoutes (DialogReplyHandler m)
toPaths = fix \go (ps, rr) -> case ps of
[] -> rr
[p] -> DialogRequestPaths (Map.singleton p rr)
p:px' -> DialogRequestPaths (Map.singleton p (go (px', rr)))
hand :: Monad m => a -> b -> ListBuilderT m (a, b)
hand = curry li
handconv :: (Monad m, Monad m', Serialise req, Serialise resp)
=> a
-> Text
-> (req -> ExceptT ResponseStatus m resp)
-> ListBuilderT m' (a, Frames -> Either Text ((Frames -> m ()) -> m (), Frames))
handconv path msg h =
hand path $ processReply msg h
---
processReply :: forall m m' req resp .
( Monad m
, Serialise req
, Serialise resp
, m' ~ ExceptT ResponseStatus m
)
=> Text
-> (req -> m' resp)
-> Frames
-> Either Text ((Frames -> m ()) -> m (), Frames)
processReply msg h = runExcept . runStateT do
flip runReply . h <$> cutFrameDecode msg
runReply ::
( Monad m
, Serialise a
)
=> (Frames -> m r)
-> ExceptT ResponseStatus m a
-> m r
runReply reply =
either
(\e -> reply (Frames [serialiseS (ResponseHeader e 0)]))
(\a -> reply (Frames [serialiseS (ResponseHeader (ResponseStatus Success200 "") 0)
, serialiseS a
])
)
<=< runExceptT
---
dpath :: Text -> [ByteString] -> Frames
dpath path = Frames . (cs path :)
---
addEnvelope :: Monoid a => [a] -> Frames' a -> Frames' a
addEnvelope en = over #unFrames ((en <> [mempty]) <>)
splitEnvelope :: (Monoid a, Eq a) => Frames' a -> ([a], Frames' a)
splitEnvelope = fmap (Frames . List.drop 1) . List.break (== mempty) . unFrames
data ResponseHeader = ResponseHeader
{ respStatus :: ResponseStatus
, respSeqNumber :: Int
}
deriving (Generic, Show, Eq)
instance Serialise ResponseHeader
data ResponseStatus = ResponseStatus
{ responseStatusCode :: ResponseStatusCode
, responseStatusMessage :: Text
}
deriving (Generic, Show, Eq)
instance Serialise ResponseStatus
data ResponseStatusCode
= Success200
| SuccessNoContent204
| SuccessMore
| BadRequest400
| Forbidden403
| NotFound404
deriving (Generic, Show, Eq)
instance Serialise ResponseStatusCode
routerSignature :: Word8
routerSignature = 1
routeDialogRequest :: forall m .
Monad m
=> DialogRequestRouter m
-> Frames
-> (Frames -> m ())
-> m ()
routeDialogRequest router frames rawReplyToPeer = do
-- error $ show router
erun <- pure $ runExcept $ flip evalStateT req do
signature <- cutFrameDecode
(ResponseStatus BadRequest400 "No signature in request")
when (signature /= routerSignature) $ throwError
(ResponseStatus BadRequest400 "Wrong signature in request")
path <- cutFrameOr
(ResponseStatus BadRequest400 "No path in request")
lift . ExceptT . pure
-- Если не может разобрать параметры запроса,
-- то самим ответить этому пиру '404'
-- . left (ResponseStatus BadRequest400)
. travel (BS8.split '/' path) router
-- передать оставшуюся часть запроса в хэндлер
=<< get
case erun of
Left rs -> replyToPeer (Frames [serialiseS (ResponseHeader rs 0)])
Right go ->
-- передать хэндлеру продолжение чтобы ответить этому пиру
go replyToPeer
where
(backPath, req) = splitEnvelope frames
replyToPeer :: Frames -> m ()
replyToPeer = rawReplyToPeer . over #unFrames (backPath <>)
travel :: ()
=> [ByteString]
-> DialogRequestRouter m
-> Frames
-> Either ResponseStatus ((Frames -> m ()) -> m ())
travel path'' router'' = evalStateT $ flipfix2 path'' router''
\go path -> \case
DialogRequestPaths kv -> case path of
step:path' ->
maybe
(throwError (ResponseStatus BadRequest400 "Path not found"))
(go path')
(Map.lookup step kv)
_ -> throwError (ResponseStatus BadRequest400 "Path not found (too long)")
DialogRequestPreparse hfx ->
go path =<< StateT (left (ResponseStatus BadRequest400) . hfx)
DialogRequestEndpoint ep -> pure ep
flipfix2 :: a -> b -> ((a -> b -> c) -> (a -> b -> c)) -> c
flipfix2 a b f = fix f a b
cutFrameDecode :: (Serialise b, MonadState Frames m, MonadError e m) => e -> m b
cutFrameDecode e =
State.gets unFrames >>= \case
x:xs ->
(either (const (throwError e)) pure . deserialiseOrFailS) x
<* State.put (Frames xs)
_ -> throwError e
cutFrameDecode'
:: (Serialise b, MonadState Frames m, MonadError (Maybe DeserialiseFailure) m)
=> m b
cutFrameDecode' =
State.gets unFrames >>= \case
x:xs ->
(either (throwError . Just) pure . deserialiseOrFailS) x
<* State.put (Frames xs)
_ -> throwError Nothing
cutFrameOr :: (MonadState (Frames' b) m, MonadError e m) => e -> m b
cutFrameOr e =
State.gets unFrames >>= \case
x:xs -> x <$ State.put (Frames xs)
_ -> throwError e
serialiseS :: Serialise a => a -> ByteString
serialiseS = BSL.toStrict . serialise
deserialiseOrFailS :: Serialise a => ByteString -> Either DeserialiseFailure a
deserialiseOrFailS = deserialiseOrFail . BSL.fromStrict
fromMaybeM :: Applicative m => m a -> Maybe a -> m a
fromMaybeM ma = maybe ma pure
fromJustThrowError :: MonadError e m => e -> Maybe a -> m a
fromJustThrowError = fromMaybeM . throwError
------------------------------------------
--- Type-level specification -------------
------------------------------------------
data ReqCBOR (a :: Type)
data SingleAck
data SingleRespCBOR (a :: Type)
data StreamingRespCBOR (a :: Type)
data NamedSpec (spec :: Type -> Type)
class DialMode mode where
type mode &- spec :: Type
infixl 0 &-
data (path :: k) &/ (a :: Type)
deriving (Typeable)
infixr 4 &/
type path &// a = path &/ NamedSpec a
infixr 4 &//
---
data ModePlain
instance DialMode ModePlain where
type ModePlain &- spec = spec
---
data ModeServerT (m :: Type -> Type)
instance DialMode (ModeServerT m) where
type ModeServerT m &- spec = HandlerD spec m
class HasHandler m spec ctx where
type HandlerD spec (m' :: Type -> Type) :: Type
route ::
Proxy spec
-> Ctx ctx
-> HandlerD spec (DialHandlerT m)
-> DialogRequestRouter m
hoistDialogWithContext
:: Proxy spec
-> Proxy ctx
-> (forall x. m x -> n x)
-> HandlerD spec m
-> HandlerD spec n
data EmptyCX -- '[]
data Ctx ctx where
EmptyCtx :: Ctx EmptyCX
-- (:&.) :: x -> Ctx xs -> Ctx (x ': xs)
-- infixr 5 :&.
-- hoistTRouter :: forall t m n .
-- (MonadTrans t, Monad m, Monad n, m ~ t n)
-- => (forall a . m a -> n a)
-- -> DialogRequestRouter m
-- -> DialogRequestRouter n
-- hoistTRouter nt = fmap nt'
-- where
-- nt' :: ((x -> m y) -> m y)
-- -> ((x -> n y) -> n y)
-- nt' xtmy_tmy = nt . xtmy_tmy . fmap lift
hoistTRouter :: forall m n .
(Monad m, Monad n)
=> (forall a . m a -> n a)
-> (forall a . n a -> m a)
-> DialogRequestRouter m
-> DialogRequestRouter n
hoistTRouter ntf ntb = fmap nt'
where
nt' :: ((x -> m y) -> m y)
-> ((x -> n y) -> n y)
nt' xtmy_tmy = ntf . xtmy_tmy . fmap ntb
type DialHandlerIO a = DialHandlerT IO a
newtype DialHandlerT m a = DialHandlerT { runDialHandlerT :: ExceptT ResponseStatus m a }
deriving
( Generic, Functor, Applicative, Monad
, MonadIO
, MonadTrans
, MonadError ResponseStatus
-- , MonadUnliftIO
-- , MonadThrow, MonadCatch, MonadMask
)
---
instance (KnownSymbol path, HasHandler m spec ctx) => HasHandler m (path &/ spec) ctx where
type HandlerD (path &/ spec) m = HandlerD spec m
route _ ctx h = DialogRequestPaths $
Map.singleton (cs (symbolVal (Proxy @path))) (route (Proxy @spec) ctx h)
hoistDialogWithContext _ = hoistDialogWithContext (Proxy @spec)
---
instance
( Serialise a
, Typeable a
, HasHandler m spec ctx
) =>
HasHandler m (ReqCBOR a &/ spec) ctx where
type HandlerD (ReqCBOR a &/ spec) m = a -> HandlerD spec m
route _ ctx (ha :: a -> HandlerD spec (DialHandlerT m)) =
DialogRequestPreparse \fx -> do
(a, fx')
<- runExcept
$ flip runStateT fx
$ cutFrameDecode ((cs . show . typeRep) (Proxy @a))
pure (route (Proxy @spec) ctx (ha a), fx')
hoistDialogWithContext _ pc nt s = hoistDialogWithContext (Proxy @spec) pc nt . s
---
instance
( Applicative m
) =>
HasHandler m SingleAck ctx where
type HandlerD SingleAck m = m ()
route _ _ctx _mx =
DialogRequestEndpoint \reply -> do
reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessNoContent204 "") 0)])
hoistDialogWithContext _ _ nt hdlM = nt hdlM
---
instance
( Monad m
, Serialise a
) =>
HasHandler m (SingleRespCBOR a) ctx where
type HandlerD (SingleRespCBOR a) m = m a
route _ _ctx ma =
DialogRequestEndpoint \reply -> do
ea <- runExceptT $ runDialHandlerT ma
case ea of
Left e -> reply $ Frames [ serialiseS e ]
Right a -> reply $ Frames
[ serialiseS (ResponseHeader (ResponseStatus Success200 "") 0)
, serialiseS (a :: a)
]
hoistDialogWithContext _ _ nt hdlM = nt hdlM
---
instance
( Serialise a
) =>
HasHandler m (StreamingRespCBOR a) ctx where
type HandlerD (StreamingRespCBOR a) m = Stream (Of a) m ()
route = undefined
-- hoistDialogWithContext = undefined
---
type GServerConstraints spec m =
( GToProduct (Rep (spec (ModeServerT m))) ~ HandlerD (GToProduct (Rep (spec ModePlain))) m
, GProduct (Rep (spec (ModeServerT m)))
)
class GServer (spec :: Type -> Type) (m :: Type -> Type) where
gServerProof :: Dict (GServerConstraints spec m)
instance
( GToProduct (Rep (spec (ModeServerT m))) ~ HandlerD (GToProduct (Rep (spec ModePlain))) m
, GProduct (Rep (spec (ModeServerT m)))
) => GServer spec m where
gServerProof = Dict
instance
( HasHandler m (GToProduct (Rep (spec ModePlain))) ctx
-- , HasHandler m (GToProduct (Rep (spec (ModeServerT m)))) ctx
-- , GProduct (Rep (spec ModePlain))
, forall q . Generic (spec (ModeServerT q))
, forall q . GServer spec q
) =>
HasHandler m (NamedSpec spec) ctx where
type HandlerD (NamedSpec spec) m = spec (ModeServerT m)
route ::
Proxy (NamedSpec spec)
-> Ctx ctx
-> spec (ModeServerT (DialHandlerT m))
-> DialogRequestRouter m
route _ ctx spec =
case gServerProof @spec @(DialHandlerT m) of
Dict -> route (Proxy @(GToProduct (Rep (spec ModePlain)))) ctx (toProduct spec)
hoistDialogWithContext
:: forall n. Proxy (NamedSpec spec)
-> Proxy ctx
-> (forall x. m x -> n x)
-> spec (ModeServerT m)
-> spec (ModeServerT n)
hoistDialogWithContext _ pctx nat dl =
case (gServerProof @spec @m, gServerProof @spec @n) of
(Dict, Dict) ->
fromProduct dlN
where
dlM :: HandlerD (GToProduct (Rep (spec ModePlain))) m =
toProduct dl
dlN :: HandlerD (GToProduct (Rep (spec ModePlain))) n =
hoistDialogWithContext (Proxy @(GToProduct (Rep (spec ModePlain)))) pctx nat dlM
toProduct :: (Generic (spec mode), GProduct (Rep (spec mode)))
=> spec mode -> GToProduct (Rep (spec mode))
toProduct = gtoProduct . Generics.from
fromProduct
:: (Generic (spec mode), GProduct (Rep (spec mode)))
=> GToProduct (Rep (spec mode)) -> spec mode
fromProduct = Generics.to . gfromProduct
instance
( HasHandler m speca ctx
, HasHandler m specb ctx
) =>
HasHandler m (GP speca specb) ctx where
type HandlerD (GP speca specb) m = GP (HandlerD speca m) (HandlerD specb m)
route _ ctx (GP speca specb) =
route (Proxy @speca) ctx speca
<> route (Proxy @specb) ctx specb
hoistDialogWithContext _ pc nt (GP speca specb) =
GP
(hoistDialogWithContext (Proxy @speca) pc nt speca)
(hoistDialogWithContext (Proxy @specb) pc nt specb)
data GP a b = GP a b
class GProduct f where
type GToProduct (f :: Type -> Type)
gtoProduct :: f p -> GToProduct f
gfromProduct :: GToProduct f -> f p
instance (GProduct l, GProduct r) => GProduct (l :*: r) where
type GToProduct (l :*: r) = GP (GToProduct l) (GToProduct r)
gtoProduct (l :*: r) = GP (gtoProduct l) (gtoProduct r)
gfromProduct (GP l r) = gfromProduct l :*: gfromProduct r
instance GProduct f => GProduct (M1 i c f) where
type GToProduct (M1 i c f) = GToProduct f
gtoProduct = gtoProduct . unM1
gfromProduct = M1 . gfromProduct
instance GProduct (K1 i c) where
type GToProduct (K1 i c) = c
gtoProduct = unK1
gfromProduct = K1

2
hbs2-core/lib/Dialog/Helpers/List.hs → hbs2-core/lib/HBS2/Net/Dialog/Helpers/List.hs
View File

@ -1,4 +1,4 @@
module Dialog.Helpers.List where
module HBS2.Net.Dialog.Helpers.List where
import Control.Monad.Trans.Writer.CPS qualified as W
import Data.Functor.Identity

2
hbs2-core/lib/Dialog/Helpers/Streaming.hs → hbs2-core/lib/HBS2/Net/Dialog/Helpers/Streaming.hs
View File

@ -1,4 +1,4 @@
module Dialog.Helpers.Streaming where
module HBS2.Net.Dialog.Helpers.Streaming where
import Control.Monad.Fix
import Data.ByteString qualified as BS

62
hbs2-core/lib/HBS2/Net/Proto/Dialog.hs
View File

@ -3,39 +3,24 @@
module HBS2.Net.Proto.Dialog
( module HBS2.Net.Proto.Dialog
, module Dialog.Core
, module Dialog.Client
, module HBS2.Net.Dialog.Core
, module HBS2.Net.Dialog.Client
) where
import HBS2.Actors.Peer
import HBS2.Clock
import HBS2.Data.Types
import HBS2.Net.Auth.Credentials
import HBS2.Net.Proto
import HBS2.Net.Proto.Peer
import HBS2.Net.Proto.Sessions
import HBS2.Prelude.Plated hiding (at)
import HBS2.System.Logger.Simple
import Codec.Serialise (deserialiseOrFail)
import Control.Arrow
import Control.Monad
import Control.Monad.Error.Class
import Control.Monad.IO.Unlift
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Builder
import Data.ByteString.Lazy qualified as BSL
import Data.List qualified as List
import Data.Map.Strict as Map
import Data.Generics.Product.Fields ()
import Data.Kind
import Lens.Micro.Platform
import Streaming as S
import Streaming.Prelude qualified as S
import UnliftIO.Exception
import UnliftIO.STM
import Dialog.Client
import Dialog.Core
import HBS2.Data.Types
import HBS2.Net.Dialog.Client
import HBS2.Net.Dialog.Core
import HBS2.Net.Proto
import HBS2.Prelude.Plated hiding (at)
---
@ -62,7 +47,7 @@ dialRespEncode = \case
---
data DialogProtoEnv m e = DialogProtoEnv
newtype DialogProtoEnv m e = DialogProtoEnv
{ dialogProtoEnvCallerEnv :: CallerEnv m
}
@ -76,12 +61,12 @@ newDialogProtoEnv = do
-- Adapters should share the same env
data DialReqProtoAdapter e (m :: * -> *) s = DialReqProtoAdapter
{ dialReqProtoAdapterRouter :: DialogRequestRouter m
-- , dialReqProtoAdapterEnv :: DialogProtoEnv e
data DialReqProtoAdapter e (m :: Type -> Type) s = DialReqProtoAdapter
{ dialReqProtoAdapterDApp :: DApp IO
, dialReqProtoAdapterNT :: Peer e -> forall a . m a -> IO a
}
data DialRespProtoAdapter e (m :: * -> *) s = DialRespProtoAdapter
newtype DialRespProtoAdapter e (m :: Type -> Type) s = DialRespProtoAdapter
{ dialRespProtoAdapterEnv :: DialogProtoEnv m e
}
@ -98,19 +83,22 @@ dialReqProto :: forall e s m .
=> DialReqProtoAdapter e m s
-> DialReq e
-> m ()
dialReqProto DialReqProtoAdapter{..} = unDialReq >>> \frames -> do
dialReqProto adapter = unDialReq >>> \frames -> do
peer <- thatPeer dialReqProtoProxy
let dialReqEnv :: DialogRequestEnv m (Peer e) (Maybe (PeerData e))
dialReqEnv = DialogRequestEnv
{ dreqEnvPeer = peer
, dreqEnvGetPeerData = pure Nothing -- undefined -- find (KnownPeerKey peer) id
}
-- let dialReqEnv :: DialogRequestEnv m (Peer e) (Maybe (PeerData e))
-- dialReqEnv = DialogRequestEnv
-- { dreqEnvPeer = peer
-- , dreqEnvGetPeerData = pure Nothing -- undefined -- find (KnownPeerKey peer) id
-- }
let replyToPeer :: Frames -> m ()
replyToPeer = request peer . DialResp @e
routeDialogRequest dialReqProtoAdapterRouter dialReqEnv replyToPeer frames
let replyToPeerIO :: Frames -> IO ()
replyToPeerIO = dialReqProtoAdapterNT adapter peer <$> replyToPeer
liftIO $ (dialReqProtoAdapterDApp adapter) frames replyToPeerIO
where
dialReqProtoProxy = Proxy @(DialReq e)
@ -127,7 +115,7 @@ dialRespProto :: forall e s m .
-> DialResp e
-> m ()
dialRespProto DialRespProtoAdapter{..} = unDialResp >>> unFrames >>> \case
"": xs -> do
"": _xs -> do
-- Ответили прямо нам сюда. Нужно как-то отреагировать на xs
pure ()

12
hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs
View File

@ -15,6 +15,7 @@ import HBS2.System.Logger.Simple
import Crypto.Saltine.Core.Box qualified as Encrypt
import Data.ByteString qualified as BS
import Data.Hashable hiding (Hashed)
import Data.String.Conversions (cs)
import Lens.Micro.Platform
@ -68,6 +69,10 @@ sendBeginEncryptionExchange creds ourpubkey peer = do
data EncryptionHandshakeAdapter e m s = EncryptionHandshakeAdapter
{ encHandshake_considerPeerAsymmKey :: Peer e -> Maybe Encrypt.PublicKey -> m ()
, encAsymmetricKeyPair :: AsymmKeypair (Encryption e)
, encGetEncryptionKey :: EncryptionKeyIDKey e -> m (Maybe (CommonSecret (Encryption e)))
}
@ -88,11 +93,10 @@ encryptionHandshakeProto :: forall e s m .
, Show (Nonce ())
)
=> EncryptionHandshakeAdapter e m s
-> PeerEnv e
-> EncryptionHandshake e
-> m ()
encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case
encryptionHandshakeProto EncryptionHandshakeAdapter{..} = \case
ResetEncryptionKeys -> do
peer <- thatPeer proto
@ -104,7 +108,7 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case
encHandshake_considerPeerAsymmKey peer Nothing
creds <- getCredentials @s
let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv
ourpubkey <- pure $ pubKeyFromKeypair @s $ encAsymmetricKeyPair
sendBeginEncryptionExchange @e creds ourpubkey peer
BeginEncryptionExchange theirsign theirpubkey -> do
@ -117,7 +121,7 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case
-- взять свои ключи
creds <- getCredentials @s
let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv
ourpubkey <- pure $ pubKeyFromKeypair @s $ encAsymmetricKeyPair
-- подписать нонс
let sign = makeSign @s (view peerSignSk creds) ((cs . serialise) ourpubkey)

34
hbs2-core/lib/HBS2/Net/Proto/Peer.hs
View File

@ -7,6 +7,7 @@ import HBS2.Actors.Peer
import HBS2.Data.Types
import HBS2.Events
import HBS2.Net.Proto
import HBS2.Net.Proto.Types
import HBS2.Clock
import HBS2.Net.Proto.Sessions
import HBS2.Prelude.Plated
@ -228,3 +229,36 @@ instance ( Serialise (PubKey 'Sign (Encryption e))
=> Serialise (PeerHandshake e)
---
data EncryptionKeyIDKey e =
EncryptionKeyIDKey
{ ekeyIDPeerSignKey :: PubKey 'Sign (Encryption e)
, ekeyIDPeerNonce :: PeerNonce
}
deriving (Generic)
deriving instance
( Show (PubKey 'Sign (Encryption e))
, Show (Nonce ())
) => Show (EncryptionKeyIDKey e)
deriving instance
( Eq (PubKey 'Sign (Encryption e))
, Eq (Nonce ())
) => Eq (EncryptionKeyIDKey e)
instance (
Hashable (PubKey 'Sign (Encryption e))
, Hashable (Nonce ())
) => Hashable (EncryptionKeyIDKey e) where
hashWithSalt s EncryptionKeyIDKey {..} =
hashWithSalt s (ekeyIDPeerSignKey, ekeyIDPeerNonce)
encryptionKeyIDKeyFromPeerData :: PeerData e -> EncryptionKeyIDKey e
encryptionKeyIDKeyFromPeerData PeerData{..} =
EncryptionKeyIDKey
{ ekeyIDPeerSignKey = _peerSignKey
, ekeyIDPeerNonce = _peerOwnNonce
}

6
hbs2-core/lib/HBS2/Net/Proto/Types.hs
View File

@ -28,6 +28,11 @@ import Control.Monad.Trans.Maybe
-- e -> Transport (like, UDP or TChan)
-- p -> L4 Protocol (like Ping/Pong)
data CryptoAction = Sign | Encrypt
type family PubKey ( a :: CryptoAction) e :: Type
type family PrivKey ( a :: CryptoAction) e :: Type
type family Encryption e :: Type
-- FIXME: move-to-a-crypto-definition-modules
@ -206,4 +211,3 @@ instance FromStringMaybe (PeerAddr L4Proto) where
instance Serialise L4Proto
instance Serialise (PeerAddr L4Proto)

8
hbs2-core/test/DialogSpec.hs
View File

@ -14,8 +14,8 @@ import GHC.Generics (Generic)
import Lens.Micro.Platform
import System.IO
import Dialog.Core
import Dialog.Helpers.List
import HBS2.Net.Dialog.Core
import HBS2.Net.Dialog.Helpers.List
newtype BSA = BSA { unBSA :: ByteString }
deriving (Generic, Show)
@ -57,3 +57,7 @@ testDialog = testGroup "dialog" $ buildList do
property' "roundtrip encode Frames" \ xs ->
(decodeFrames . encodeFrames) xs == Right xs
property' "encodeFrames is quasidistributive over mappend" \ (xs, ys) ->
BS.drop (BS.length (encodeFrames xs)) (encodeFrames (xs <> ys))
== encodeFrames ys

11
hbs2-peer/app/EncryptionKeys.hs
View File

@ -56,15 +56,14 @@ encryptionHandshakeWorker :: forall e m s .
-- , HasCredentials s m
)
=> PeerConfig
-> PeerEnv e
-> PeerCredentials s
-> EncryptionHandshakeAdapter e m s
-> m ()
encryptionHandshakeWorker pconf penv creds EncryptionHandshakeAdapter{..} = do
encryptionHandshakeWorker pconf creds EncryptionHandshakeAdapter{..} = do
-- e :: PeerEnv e <- ask
let ourpubkey = pubKeyFromKeypair @s $ _envAsymmetricKeyPair penv
ourpubkey <- pure $ pubKeyFromKeypair @s $ encAsymmetricKeyPair
pl <- getPeerLocator @e
@ -75,9 +74,9 @@ encryptionHandshakeWorker pconf penv creds EncryptionHandshakeAdapter{..} = do
forM_ peers \peer -> do
-- Только если ещё не знаем ключ ноды
mpeerData <- find (KnownPeerKey peer) id
mkey <- liftIO do
join <$> forM mpeerData \peerData -> getEncryptionKey penv peerData
mencKeyID <- (fmap . fmap) encryptionKeyIDKeyFromPeerData $
find (KnownPeerKey peer) id
mkey <- join <$> mapM encGetEncryptionKey mencKeyID
case mkey of
Just _ -> pure ()
Nothing -> sendBeginEncryptionExchange @e creds ourpubkey peer

82
hbs2-peer/app/PeerMain.hs
View File

@ -57,7 +57,8 @@ import RefLog (reflogWorker)
import HttpWorker
import ProxyMessaging
import PeerMain.DialogCliCommand
import PeerMain.PeerDialog
import PeerMain.Dialog.Server
import PeerMain.Dialog.Spec
import PeerMeta
import CLI.RefChan
import RefChan
@ -448,7 +449,7 @@ runPeer :: forall e s . ( e ~ L4Proto
, FromStringMaybe (PeerAddr e)
, s ~ Encryption e
, HasStorage (PeerM e IO)
) => PeerOpts -> IO ()
)=> PeerOpts -> IO ()
runPeer opts = Exception.handle (\e -> myException e
>> performGC
@ -574,32 +575,35 @@ runPeer opts = Exception.handle (\e -> myException e
pure $ Just tcpEnv
(proxy, penv) <- mdo
proxy <- newProxyMessaging mess tcp >>= \peer -> pure peer
proxy <- newProxyMessaging mess tcp >>= \proxy' -> pure proxy'
{ _proxy_getEncryptionKey = \peer -> do
mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id
mkey <- join <$> forM mpeerData \peerData -> getEncryptionKey penv peerData
mencKeyID <- (fmap . fmap) encryptionKeyIDKeyFromPeerData $
withPeerM penv $ find (KnownPeerKey peer) id
mkey <- join <$> forM mencKeyID \encKeyID ->
getEncryptionKey proxy encKeyID
case mkey of
Nothing ->
trace1 $ "ENCRYPTION empty getEncryptionKey"
<+> pretty peer <+> viaShow mpeerData
<+> pretty peer <+> viaShow mencKeyID
Just k ->
trace1 $ "ENCRYPTION success getEncryptionKey"
<+> pretty peer <+> viaShow mpeerData <+> viaShow k
<+> pretty peer <+> viaShow mencKeyID <+> viaShow k
pure mkey
, _proxy_clearEncryptionKey = \peer -> do
mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id
forM_ mpeerData \peerData -> setEncryptionKey penv peer peerData Nothing
mencKeyID <- (fmap . fmap) encryptionKeyIDKeyFromPeerData $
withPeerM penv $ find (KnownPeerKey peer) id
forM_ mencKeyID \encKeyID -> setEncryptionKey proxy peer encKeyID Nothing
-- deletePeerAsymmKey brains peer
forM_ mpeerData \peerData ->
deletePeerAsymmKey' brains (show peerData)
forM_ mencKeyID \encKeyID ->
deletePeerAsymmKey' brains (show encKeyID)
, _proxy_sendResetEncryptionKeys = \peer -> withPeerM penv do
sendResetEncryptionKeys peer
, _proxy_sendBeginEncryptionExchange = \peer -> withPeerM penv do
sendBeginEncryptionExchange pc
((pubKeyFromKeypair @s . view envAsymmetricKeyPair) penv)
((pubKeyFromKeypair @s . _proxy_asymmetricKeyPair) proxy)
peer
}
@ -690,32 +694,37 @@ runPeer opts = Exception.handle (\e -> myException e
) => EncryptionHandshakeAdapter L4Proto m s
encryptionHshakeAdapter = EncryptionHandshakeAdapter
{ encHandshake_considerPeerAsymmKey = \peer mpubkey -> withPeerM penv do
mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id
mencKeyID <- (fmap . fmap) encryptionKeyIDKeyFromPeerData $
withPeerM penv $ find (KnownPeerKey peer) id
case mpubkey of
Nothing -> do
-- trace $ "ENCRYPTION delete key" <+> pretty peer <+> viaShow mpeerData
-- trace $ "ENCRYPTION delete key" <+> pretty peer <+> viaShow mencKeyID
-- deletePeerAsymmKey brains peer
forM_ mpeerData \peerData ->
deletePeerAsymmKey' brains (show peerData)
forM_ mencKeyID \encKeyID ->
deletePeerAsymmKey' brains (show encKeyID)
Just pk -> do
-- emit PeerAsymmInfoKey (PeerAsymmPubKey peer pk)
let symmk = genCommonSecret @s
(privKeyFromKeypair @s (view envAsymmetricKeyPair penv))
(privKeyFromKeypair @s (_proxy_asymmetricKeyPair proxy))
pk
case mpeerData of
case mencKeyID of
Nothing -> do
-- insertPeerAsymmKey brains peer pk symmk
-- insertPeerAsymmKey' brains (show peer) pk symmk
trace $ "ENCRYPTION can not store key. No peerData"
<+> pretty peer <+> viaShow mpeerData
Just peerData -> do
liftIO $ setEncryptionKey penv peer peerData (Just symmk)
insertPeerAsymmKey' brains (show peerData) pk symmk
trace $ "ENCRYPTION can not store key. No encKeyID"
<+> pretty peer <+> viaShow mencKeyID
Just encKeyID -> do
liftIO $ setEncryptionKey proxy peer encKeyID (Just symmk)
insertPeerAsymmKey' brains (show encKeyID) pk symmk
, encAsymmetricKeyPair = _proxy_asymmetricKeyPair proxy
, encGetEncryptionKey = liftIO . getEncryptionKey proxy
}
-- dialReqProtoAdapter <- do
-- dialReqProtoAdapterRouter <- pure dialogRoutes
-- dialReqProtoAdapterDApp <- pure dialogRoutes
-- pure DialReqProtoAdapter {..}
env <- ask
@ -727,11 +736,12 @@ runPeer opts = Exception.handle (\e -> myException e
addPeers @e pl ps
subscribe @e PeerExpiredEventKey \(PeerExpiredEvent peer {-mpeerData-}) -> liftIO do
mpeerData <- withPeerM penv $ find (KnownPeerKey peer) id
forM_ mpeerData \peerData -> setEncryptionKey penv peer peerData Nothing
mencKeyID <- (fmap . fmap) encryptionKeyIDKeyFromPeerData $
withPeerM penv $ find (KnownPeerKey peer) id
forM_ mencKeyID \encKeyID -> setEncryptionKey proxy peer encKeyID Nothing
-- deletePeerAsymmKey brains peer
forM_ mpeerData \peerData ->
deletePeerAsymmKey' brains (show peerData)
forM_ mencKeyID \encKeyID ->
deletePeerAsymmKey' brains (show encKeyID)
subscribe @e PeerAnnounceEventKey $ \(PeerAnnounceEvent pip nonce) -> do
unless (nonce == pnonce) $ do
@ -874,7 +884,7 @@ runPeer opts = Exception.handle (\e -> myException e
peerThread "blockDownloadLoop" (blockDownloadLoop denv)
peerThread "encryptionHandshakeWorker"
(EncryptionKeys.encryptionHandshakeWorker @e conf penv pc encryptionHshakeAdapter)
(EncryptionKeys.encryptionHandshakeWorker @e conf pc encryptionHshakeAdapter)
let tcpProbeWait :: Timeout 'Seconds
tcpProbeWait = (fromInteger . fromMaybe 300) (cfgValue @PeerTcpProbeWaitKey conf)
@ -994,7 +1004,7 @@ runPeer opts = Exception.handle (\e -> myException e
, makeResponse (blockChunksProto adapter)
, makeResponse blockAnnounceProto
, makeResponse (withCredentials @e pc . peerHandShakeProto hshakeAdapter penv)
, makeResponse (withCredentials @e pc . encryptionHandshakeProto encryptionHshakeAdapter penv)
, makeResponse (withCredentials @e pc . encryptionHandshakeProto encryptionHshakeAdapter)
, makeResponse (peerExchangeProto pexFilt)
, makeResponse (refLogUpdateProto reflogAdapter)
, makeResponse (refLogRequestProto reflogReqAdapter)
@ -1199,7 +1209,17 @@ runPeer opts = Exception.handle (\e -> myException e
}
dialReqProtoAdapter <- do
dialReqProtoAdapterRouter <- pure dialogRoutes
let denv = DialEnv
let dialReqProtoAdapterDApp = drpcFullDApp denv penv
-- dialReqProtoAdapterNT :: ResponseM L4Proto (RpcM (ResourceT IO)) a -> IO a
dialReqProtoAdapterNT :: Peer e -> forall a . ResponseM L4Proto (RpcM (ResourceT IO)) a -> IO a
dialReqProtoAdapterNT = \peer ->
runResourceT
. runRPC udp1
. runResponseM peer
pure DialReqProtoAdapter {..}
rpc <- async $ runRPC udp1 do

178
hbs2-peer/app/PeerMain/Dialog/Server.hs Normal file
View File

@ -0,0 +1,178 @@
{-# LANGUAGE PolyKinds #-}
{-# Language AllowAmbiguousTypes #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE UndecidableInstances #-}
module PeerMain.Dialog.Server where
import Codec.Serialise
import Control.Monad.Except
import Control.Monad.IO.Class ()
import Control.Monad.Reader
import Lens.Micro.Platform
import HBS2.Actors.Peer
import HBS2.Data.Types.Refs
import HBS2.Hash
import HBS2.Net.Dialog.Core
import HBS2.Net.Proto.RefLog
import HBS2.Net.Proto.Types
import HBS2.Prelude
import HBS2.Storage.Simple
import PeerMain.Dialog.Spec
---
data DialEnv = DialEnv
newtype DialT m a = DialT { unDialT :: PeerM L4Proto (ReaderT DialEnv (DialHandlerT m)) a }
deriving
( Generic, Functor, Applicative, Monad
, MonadIO
, MonadReader (PeerEnv L4Proto)
-- , MonadTrans
-- , MonadError ResponseStatus
-- , MonadThrow, MonadCatch, MonadMask
)
-- instance Monad m => MonadReader DialEnv (DialT m) where
-- ask = DialT . lift $ ask
-- local f ma = undefined
instance Monad m => HasStorage (DialT m) where
getStorage = asks (view envStorage)
instance MonadTrans DialT where
lift = DialT . lift . lift . lift
instance Monad m =>
MonadError ResponseStatus (DialT m) where
-- {-# MINIMAL throwError, catchError #-}
-- throwError :: e -> m a
throwError = DialT . lift . throwError
-- catchError :: m a -> (e -> m a) -> m a
catchError = undefined
---
runDialTtoDialHandlerT :: MonadIO m => DialEnv -> PeerEnv L4Proto -> DialT m a -> DialHandlerT m a
runDialTtoDialHandlerT denv penv =
flip runReaderT denv . withPeerM penv . unDialT
---
dialogRoutes' :: forall m .
( MonadIO m
, Serialise (PubKey 'Sign (Encryption L4Proto))
, FromStringMaybe (PubKey 'Sign (Encryption L4Proto))
, Hashable (PubKey 'Sign (Encryption L4Proto))
)
=> PeerEnv L4Proto
-> DialogRequestRouter m
dialogRoutes' penv = dialogRequestRoutes do
hand ["ping"] \req -> (, req) <$> Right \reply -> do
reply (Frames [serialiseS (ResponseHeader (ResponseStatus Success200 "") 0), "pong"])
hand ["spec"] \req -> (, req) <$> Right \reply -> do
undefined
-- let xs = Map.keys (unDialogRequestRouter (dialogRoutes @m penv))
-- forM_ (zip (zip [1..] xs) ((True <$ drop 1 xs) <> [False])) \((j,x),isMore) -> do
-- reply (Frames [serialiseS (ResponseHeader (ResponseStatus (bool Success200 SuccessMore isMore) "") j)
-- , BS.intercalate "/" x
-- ])
hand ["debug", "no-response-header"] \req -> (, req) <$> Right \reply -> do
reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 0), "one"])
reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 1), "two"])
reply (Frames [])
hand ["debug", "wrong-header"] \req -> (, req) <$> Right \reply -> do
reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 0), "correct-header"])
reply (Frames ["wrong-header"])
hand ["debug", "timeout"] \req -> (, req) <$> Right \reply -> do
reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 0), "false more"])
handconv ["reflog", "get"] "ReflogGetReq" \(ReflogGetReq ref) -> do
sto <- withPeerM penv getStorage
hash <- maybe (throwError (ResponseStatus NotFound404 "unknown reference")) pure
=<< liftIO do
getRef sto (RefLogKey @(Encryption L4Proto) ref)
pure (ReflogGetResp hash)
newtype ReflogGetReq = ReflogGetReq (PubKey 'Sign (Encryption L4Proto))
deriving (Generic)
instance Serialise (PubKey 'Sign (Encryption L4Proto))
=> Serialise ReflogGetReq
newtype ReflogGetResp = ReflogGetResp (Hash HbSync)
deriving (Generic)
instance Serialise (PubKey 'Sign (Encryption L4Proto))
=> Serialise ReflogGetResp
---
drpcFullDApp :: forall m .
( MonadIO m
, Unconstraints
)
=> DialEnv -> PeerEnv L4Proto -> DApp m
drpcFullDApp denv penv =
mkDApp
(Proxy @(NamedSpec DialogRPCSpec))
EmptyCtx
(runDialTtoDialHandlerT denv penv)
-- (drpcFullH :: DialogRPCSpec (ModeServerT (DialT m)))
drpcFullH
type ConstraintsH m =
( MonadIO m
, MonadError ResponseStatus m
, HasStorage m
, Unconstraints
)
type Unconstraints =
( Serialise (PubKey 'Sign (Encryption L4Proto))
, Hashable (PubKey 'Sign (Encryption L4Proto))
, Show (PubKey 'Sign (Encryption L4Proto))
, Typeable (PubKey 'Sign (Encryption L4Proto))
, FromStringMaybe (PubKey 'Sign (Encryption L4Proto))
)
drpcFullH :: ( ConstraintsH m )
=> DialogRPCSpec (ModeServerT m)
drpcFullH = DialogRPCSpec
{ drpcPing = pure "pong"
, drpcSpec = pure "tbd"
, drpcReflog = reflogH
}
reflogH :: ( ConstraintsH m )
=> RPCReflogSpec (ModeServerT m)
reflogH = RPCReflogSpec {..}
where
reflogGet ref = do
sto <- getStorage
hash <- maybe (throwError (ResponseStatus NotFound404 "unknown reference")) pure
=<< liftIO do
getRef sto (RefLogKey @(Encryption L4Proto) ref)
pure hash
reflogFetch pk = do
liftIO $ print pk
pure ()

35
hbs2-peer/app/PeerMain/Dialog/Spec.hs Normal file
View File

@ -0,0 +1,35 @@
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE StrictData #-}
module PeerMain.Dialog.Spec where
-- import Codec.Serialise
-- import Streaming
import Data.Text (Text)
import GHC.Generics (Generic)
import HBS2.Hash
import HBS2.Net.Dialog.Core
import HBS2.Net.Proto.Types
data DialogRPCSpec r = DialogRPCSpec
{ drpcPing :: r &- "ping" &/ SingleRespCBOR Text
, drpcSpec :: r &- "spec" &/ SingleRespCBOR Text
, drpcReflog :: r &- "reflog" &// RPCReflogSpec
}
deriving (Generic)
data RPCReflogSpec r = RPCReflogSpec
{ reflogGet :: r &- "get"
&/ ReqCBOR (PubKey 'Sign (Encryption L4Proto))
&/ SingleRespCBOR (Hash HbSync)
, reflogFetch :: r &- "fetch"
&/ ReqCBOR (PubKey 'Sign (Encryption L4Proto))
&/ SingleAck
}
deriving (Generic)

106
hbs2-peer/app/PeerMain/DialogCliCommand.hs
View File

@ -2,109 +2,66 @@
module PeerMain.DialogCliCommand where
-- import Data.Generics.Labels
-- import Data.Generics.Product.Fields
import Data.Generics.Labels
import Data.Generics.Product.Fields
import HBS2.Actors.Peer
import HBS2.Base58
import HBS2.Clock
import HBS2.Net.Proto.RefLog (RefLogKey(..))
import HBS2.Defaults
import HBS2.Events
import HBS2.Hash
import HBS2.Merkle
import HBS2.Net.Auth.Credentials
import HBS2.Net.IP.Addr
import HBS2.Net.Messaging
import HBS2.Net.Messaging.TCP
import HBS2.Net.Messaging.UDP
import HBS2.Net.PeerLocator
import HBS2.Net.Proto
import HBS2.Net.Proto.Definition
import HBS2.Net.Proto.Dialog
import HBS2.Net.Proto.Peer
import HBS2.Net.Proto.PeerAnnounce
import HBS2.Net.Proto.PeerExchange
import HBS2.Net.Proto.PeerMeta
import HBS2.Net.Proto.RefLog
import HBS2.Net.Proto.Sessions
import HBS2.Net.Proto.Types
import HBS2.OrDie
import HBS2.Prelude
import HBS2.Prelude.Plated
import HBS2.Storage.Simple
import HBS2.System.Logger.Simple hiding (info)
import HBS2.System.Logger.Simple qualified as Log
import BlockDownload
import BlockHttpDownload
import Bootstrap
import Brains
import CheckMetrics
import DownloadQ
import HttpWorker
import PeerConfig
import PeerInfo
import PeerMeta
import PeerTypes
import ProxyMessaging
import RefLog (reflogWorker)
import RefLog qualified
import RPC
import RPC (PeerRpcKey, RpcM, runRPC)
import Control.Monad
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Control.Monad.Except (Except(..), ExceptT(..), runExcept, runExceptT)
import Control.Monad.State.Strict (evalStateT)
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Maybe
import Crypto.Saltine.Core.Box qualified as Encrypt
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy qualified as LBS
import Data.Default
import Data.Function
import Data.Functor
import Data.Kind
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.Monoid qualified as Monoid
import Data.Set qualified as Set
import Data.String.Conversions as X (cs)
import Data.Void (absurd, Void)
import Lens.Micro.Platform
import Network.Socket
import Options.Applicative
import Streaming as S
import Streaming.Prelude qualified as S
import System.Directory
import System.IO
import UnliftIO.Async
import UnliftIO.Concurrent
import UnliftIO.Exception as U
import UnliftIO.Resource
-- import System.FilePath.Posix
import System.IO
import System.Exit
pDialog :: Parser (IO ())
pDialog = hsubparser $ mempty
<> command "ping" (info pPing (progDesc "ping hbs2 node via dialog inteface") )
<> command "debug" (info pDebug (progDesc "debug call different dialog inteface routes") )
<> command "reflog" (info pReflog (progDesc "reflog commands") )
pReflog :: Parser (IO ())
pReflog = hsubparser $ mempty
<> command "get" (info pRefLogGet (progDesc "get own reflog from all" ))
<> command "fetch" (info pRefLogFetch (progDesc "fetch reflog from all" ))
confOpt :: Parser FilePath
confOpt = strOption ( long "config" <> short 'c' <> help "config" )
data OptInitial (f :: * -> *) a b = OptInitial { unOptInitial :: f a }
newtype OptInitial (f :: Type -> Type) a b = OptInitial { unOptInitial :: f a }
deriving (Generic, Show)
data OptResolved (f :: * -> *) a b = OptResolved { unOptResolved :: b }
newtype OptResolved (f :: Type -> Type) a b = OptResolved { unOptResolved :: b }
deriving (Generic, Show)
type DialOptInitial = DialOpt OptInitial
type DialOptResolved = DialOpt OptResolved
data DialOpt (f :: (* -> *) -> * -> * -> *) = DialOpt
data DialOpt (f :: (Type -> Type) -> Type -> Type -> Type) = DialOpt
{ dialOptConf :: f Maybe FilePath PeerConfig
, dialOptAddr :: f Maybe String (Peer L4Proto)
}
@ -133,7 +90,7 @@ resolveDialOpt dopt = do
`orDieM` "Dial endpoint not set"
as <- parseAddrUDP (cs saddr) <&> fmap (fromSockAddr @'UDP . addrAddress)
peer <- (headMay $ List.sortBy (compare `on` addrPriority) as)
peer <- headMay (List.sortBy (compare `on` addrPriority) as)
`orDieM` "Can't parse Dial endpoint"
pure DialOpt
@ -149,6 +106,35 @@ pPing = do
liftIO . print =<< do
dQuery1 def cli peer (dpath "ping" [])
reflogKeyP :: ReadM (PubKey 'Sign (Encryption L4Proto))
reflogKeyP = eitherReader $
maybe (Left "invalid REFLOG-KEY") pure . fromStringMay
pRefLogGet :: Parser (IO ())
pRefLogGet = do
dopt <- pDialCommon
rkey <- argument reflogKeyP ( metavar "REFLOG-KEY" )
pure do
withDial dopt \peer dclient ->
withClient dclient \cli -> do
xs <- dQuery1 def cli peer (dpath "reflog/get" [serialiseS rkey])
hash <- either (lift . lift . fail) pure $ runExcept $ flip evalStateT xs do
cutFrameDecode @(Hash HbSync) do
"No hash in response: " <> show xs
liftIO . print $ pretty hash
pRefLogFetch :: Parser (IO ())
pRefLogFetch = do
dopt <- pDialCommon
rkey <- argument reflogKeyP ( metavar "REFLOG-KEY" )
pure do
withDial dopt \peer dclient ->
withClient dclient \cli -> do
xs <- dQuery1 def cli peer (dpath "reflog/fetch" [serialiseS rkey])
liftIO . print $ "Response: " <> show xs
pDebug :: Parser (IO ())
pDebug = do

39
hbs2-peer/app/PeerMain/PeerDialog.hs
View File

@ -1,39 +0,0 @@
module PeerMain.PeerDialog where
import Control.Monad
import Control.Monad.IO.Class
import Data.Bool
import Data.ByteString qualified as BS
import Data.Map qualified as Map
import Dialog.Core
import HBS2.Net.Proto.Types
dialogRoutes :: forall m . MonadIO m => DialogRequestRouter m
dialogRoutes = dialogRequestRoutes do
hand ["ping"] \req -> Right \reply -> do
reply (Frames [serialiseS (ResponseHeader (ResponseStatus Success200 "") 0), "pong"])
hand ["spec"] \req -> Right \reply -> do
let xs = Map.keys (unDialogRequestRouter (dialogRoutes @m))
forM_ (zip (zip [1..] xs) ((True <$ drop 1 xs) <> [False])) \((j,x),isMore) -> do
reply (Frames [serialiseS (ResponseHeader (ResponseStatus (bool Success200 SuccessMore isMore) "") j)
, BS.intercalate "/" x
])
hand ["debug", "no-response-header"] \req -> Right \reply -> do
reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 0), "one"])
reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 1), "two"])
reply (Frames [])
hand ["debug", "wrong-header"] \req -> Right \reply -> do
reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 0), "correct-header"])
reply (Frames ["wrong-header"])
hand ["debug", "timeout"] \req -> Right \reply -> do
reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 0), "false more"])

6
hbs2-peer/app/PeerTypes.hs
View File

@ -443,15 +443,9 @@ mkPeerMeta conf penv = do
. fromStringMay @(PeerAddr L4Proto)
)
=<< cfgValue @PeerListenTCPKey conf
-- let useEncryption = True -- move to config
annMetaFromPeerMeta . PeerMeta $ W.execWriter do
mHttpPort `forM` \p -> elem "http-port" (TE.encodeUtf8 . Text.pack . show $ p)
mTcpPort `forM` \p -> elem "listen-tcp" (TE.encodeUtf8 . Text.pack . show $ p)
-- when useEncryption do
-- elem "ekey" (TE.encodeUtf8 . Text.pack . show $
-- (Encrypt.publicKey . _envAsymmetricKeyPair) penv
-- -- mayby sign this pubkey by node key ?
-- )
where
elem k = W.tell . L.singleton . (k ,)

40
hbs2-peer/app/ProxyMessaging.hs
View File

@ -4,6 +4,9 @@ module ProxyMessaging
, newProxyMessaging
, runProxyMessaging
, sendToPlainProxyMessaging
, getEncryptionKey
, setEncryptionKey
, encryptionKeyIDKeyFromPeerData
) where
import HBS2.Prelude.Plated
@ -34,6 +37,7 @@ import Control.Monad.Trans.Maybe
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.Hashable hiding (Hashed)
import Data.Maybe
import Data.String.Conversions (cs)
import Data.List qualified as L
@ -41,6 +45,10 @@ import Data.Map (Map)
import Data.Map qualified as Map
import Lens.Micro.Platform as Lens
import Control.Monad
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import HBS2.Data.Types.Peer
-- TODO: protocol-encryption-goes-here
@ -54,6 +62,9 @@ data ProxyMessaging =
, _proxy_clearEncryptionKey :: Peer L4Proto -> IO ()
, _proxy_sendResetEncryptionKeys :: Peer L4Proto -> IO ()
, _proxy_sendBeginEncryptionExchange :: Peer L4Proto -> IO ()
, _proxy_asymmetricKeyPair :: AsymmKeypair (Encryption L4Proto)
, _proxy_encryptionKeys :: TVar (HashMap (EncryptionKeyIDKey L4Proto) (CommonSecret (Encryption L4Proto)))
}
-- 1 нода X создаёт себе Encrypt.Keypair
@ -78,8 +89,36 @@ newProxyMessaging u t = liftIO do
let _proxy_sendResetEncryptionKeys = const (pure ())
let _proxy_sendBeginEncryptionExchange = const (pure ())
_proxy_asymmetricKeyPair <- asymmNewKeypair @(Encryption L4Proto)
_proxy_encryptionKeys <- liftIO (newTVarIO mempty)
pure ProxyMessaging {..}
---
setEncryptionKey ::
( Hashable (PubKey 'Sign (Encryption L4Proto))
, Hashable PeerNonce
, Show (PubKey 'Sign (Encryption L4Proto))
, Show PeerNonce
, Show (CommonSecret (Encryption L4Proto))
, Show (EncryptionKeyIDKey L4Proto)
) => ProxyMessaging -> Peer L4Proto -> EncryptionKeyIDKey L4Proto -> Maybe (CommonSecret (Encryption L4Proto)) -> IO ()
setEncryptionKey proxy peer pd msecret = do
atomically $ modifyTVar' (_proxy_encryptionKeys proxy) $ Lens.at pd .~ msecret
case msecret of
Nothing -> trace $ "ENCRYPTION delete key" <+> pretty peer <+> viaShow pd
Just k -> trace $ "ENCRYPTION store key" <+> pretty peer <+> viaShow pd <+> viaShow k
getEncryptionKey ::
( Hashable (PubKey 'Sign (Encryption L4Proto))
, Hashable PeerNonce
) => ProxyMessaging -> EncryptionKeyIDKey L4Proto -> IO (Maybe (CommonSecret (Encryption L4Proto)))
getEncryptionKey proxy pd =
readTVarIO (_proxy_encryptionKeys proxy) <&> preview (Lens.ix pd)
---
runProxyMessaging :: forall m . MonadIO m
=> ProxyMessaging
-> m ()
@ -103,7 +142,6 @@ runProxyMessaging env = liftIO do
liftIO $ mapM_ waitCatch [u,t]
instance Messaging ProxyMessaging L4Proto LBS.ByteString where
sendTo = sendToProxyMessaging

3
hbs2-peer/hbs2-peer.cabal
View File

@ -137,7 +137,8 @@ executable hbs2-peer
, Bootstrap
, PeerInfo
, PeerMain.DialogCliCommand
, PeerMain.PeerDialog
, PeerMain.Dialog.Server
, PeerMain.Dialog.Spec
, PeerMeta
, RPC
, PeerTypes