-
Notifications
You must be signed in to change notification settings - Fork 0
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
implement stdio<->virtual-cat tunneling
- Loading branch information
indiscrete_void
committed
Oct 7, 2024
1 parent
557e33d
commit 0d8ba2c
Showing
9 changed files
with
222 additions
and
50 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,19 +1,76 @@ | ||
| module Pnet.Daemon.Node (pnetnd) where | ||
| module Pnet.Daemon.Node (State, initialState, stateAddNode, stateDeleteNode, route, tunnelProcess, pnetnd) where | ||
|
|
||
| import Data.ByteString (ByteString) | ||
| import Control.Monad.Extra | ||
| import Data.ByteString | ||
| import Data.List qualified as List | ||
| import Data.Maybe | ||
| import Pnet | ||
| import Pnet.Routing | ||
| import Polysemy | ||
| import Polysemy.AtomicState | ||
| import Polysemy.Extra.Trace | ||
| import Polysemy.Fail | ||
| import Polysemy.Sockets | ||
| import Polysemy.Trace | ||
| import Polysemy.Transport | ||
|
|
||
| ping :: ByteString | ||
| ping = "ping" | ||
| type State s = [(s, Address)] | ||
|
|
||
| pnetnd :: (Members (TransportEffects (RoutedFrom (Maybe ByteString)) (RouteTo (Maybe ByteString))) r, Member Trace r, Member Fail r) => Sem r () | ||
| pnetnd = traceTagged "pnetnd" . traceTagged "r2 ping" $ runR2 selfAddr go >> close | ||
| initialState :: State s | ||
| initialState = [] | ||
|
|
||
| stateAddNode :: (Member (AtomicState (State s)) r) => (s, Address) -> Sem r () | ||
| stateAddNode = atomicModify' . (:) | ||
|
|
||
| stateDeleteNode :: (Member (AtomicState (State s)) r, Eq s) => (s, Address) -> Sem r () | ||
| stateDeleteNode = atomicModify' . List.delete | ||
|
|
||
| runAddress :: (Member (AtomicState (State s)) r) => (s -> InterpreterFor (Output o) r) -> Address -> InterpreterFor (Output o) r | ||
| runAddress f addr m = do | ||
| s <- lookupSocket <$> atomicGet | ||
| f s m | ||
| where | ||
| go = | ||
| (output ping >> trace (show ping)) | ||
| >> (inputOrFail >>= trace . show) | ||
| lookupSocket = fst . fromJust . List.find ((== addr) . snd) | ||
|
|
||
| route :: | ||
| forall s r. | ||
| ( Member (AtomicState (State s)) r, | ||
| Member (InputWithEOF (RouteTo ByteString)) r, | ||
| Member Trace r | ||
| ) => | ||
| (s -> InterpreterFor (Output (RoutedFrom ByteString)) r) -> | ||
| Address -> | ||
| Sem r () | ||
| route f sender = traceTagged "route" $ raise @Trace do | ||
| trace ("routing for " ++ show sender) | ||
| let sendTo :: Address -> RoutedFrom ByteString -> Sem r () | ||
| sendTo addr = runAddress f addr . output | ||
| handle (r2Sem sendTo sender) | ||
|
|
||
| tunnelProcess :: (Members (TransportEffects (RoutedFrom (Maybe ByteString)) (RouteTo (Maybe ByteString))) r, Member Trace r, Member (Output (RouteTo (Maybe NodeHandshake))) r, Member (Output (RouteTo Connection)) r) => Address -> Sem r () | ||
| tunnelProcess addr = traceTagged ("tunnel " <> show addr) do | ||
| trace ("tunneling for " ++ show addr) | ||
| connectR2 addr | ||
| runR2Output addr $ output NodeRoute | ||
| runR2 addr inputToOutput | ||
|
|
||
| pnetnd :: | ||
| ( Members (TransportEffects (RoutedFrom (Maybe ByteString)) (RouteTo (Maybe ByteString))) r, | ||
| Member (Sockets (RouteTo ByteString) (RoutedFrom ByteString) s) r, | ||
| Member (InputWithEOF (RoutedFrom (Maybe NodeHandshake))) r, | ||
| Member (InputWithEOF (RouteTo ByteString)) r, | ||
| Member (Output (RouteTo (Maybe NodeHandshake))) r, | ||
| Member (AtomicState (State s)) r, | ||
| Member Fail r, | ||
| Member Trace r, | ||
| Member (Output (RouteTo Connection)) r | ||
| ) => | ||
| Address -> | ||
| Address -> | ||
| Sem r () | ||
| pnetnd peer addr = traceTagged "pnetnd" $ raise @Trace do | ||
| trace ("accepted " <> show addr) | ||
| handshake <- runR2Input @NodeHandshake addr $ inputOrFail @NodeHandshake | ||
| case handshake of | ||
| NodeRoute -> route socketOutput peer | ||
| NodeTunnel -> tunnelProcess addr |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,37 +1,81 @@ | ||
| module Pnet.Daemon.Server (State, initialState, pnetcd) where | ||
| module Pnet.Daemon.Server (listNodes, connectNode, pnetcd) where | ||
|
|
||
| import Control.Monad.Extra | ||
| import Data.ByteString (ByteString) | ||
| import Data.List qualified as List | ||
| import Data.Maybe | ||
| import Pnet | ||
| import Pnet.Daemon.Node | ||
| import Pnet.Routing | ||
| import Polysemy | ||
| import Polysemy.AtomicState | ||
| import Polysemy.Extra.Trace | ||
| import Polysemy.Fail | ||
| import Polysemy.Sockets | ||
| import Polysemy.Trace | ||
| import Polysemy.Transport | ||
| import Text.Printf qualified as Text | ||
|
|
||
| type State s = [(s, Address)] | ||
| listNodes :: (Member (AtomicState (State s)) r, Member (Output Response) r, Member Trace r) => Sem r () | ||
| listNodes = traceTagged "ListNodes" do | ||
| nodeList <- map snd <$> atomicGet | ||
| trace (Text.printf "responding with `%s`" (show nodeList)) | ||
| output (NodeList nodeList) | ||
|
|
||
| initialState :: State s | ||
| initialState = [] | ||
| connectNode :: | ||
| ( Member (AtomicState (State s)) r, | ||
| Members (TransportEffects (RoutedFrom (Maybe (RoutedFrom Connection))) (RouteTo (Maybe (RouteTo Connection)))) r, | ||
| Members (TransportEffects (RoutedFrom (Maybe (RoutedFrom (Maybe ByteString)))) (RouteTo (Maybe (RouteTo (Maybe ByteString))))) r, | ||
| Member (Sockets (RouteTo ByteString) (RoutedFrom ByteString) s) r, | ||
| Member (Input (Maybe (RoutedFrom (Maybe (RoutedFrom (Maybe NodeHandshake)))))) r, | ||
| Member (Input (Maybe (RoutedFrom (Maybe (RouteTo ByteString))))) r, | ||
| Member (Output (RouteTo (Maybe (RouteTo (Maybe NodeHandshake))))) r, | ||
| Member Trace r, | ||
| Eq s | ||
| ) => | ||
| s -> | ||
| Transport -> | ||
| Maybe Address -> | ||
| Sem r () | ||
| connectNode s transport maybeNodeID = traceTagged "connection" do | ||
| let nodeID = fromJust maybeNodeID | ||
| trace (Text.printf "%s connected over `%s`" nodeIDStr (show transport)) | ||
| whenJust maybeNodeID (stateAddNode . entry) | ||
| traceTagged "pnetnd" . trace . show @(Either String ()) | ||
| =<< runFail | ||
| ( runR2 @(RoutedFrom Connection) @(RouteTo Connection) defaultAddr | ||
| . runR2 @(RoutedFrom (Maybe ByteString)) @(RouteTo (Maybe ByteString)) defaultAddr | ||
| . runR2 @(RoutedFrom (Maybe NodeHandshake)) @(RouteTo (Maybe NodeHandshake)) defaultAddr | ||
| . runR2Input @(RouteTo ByteString) defaultAddr | ||
| . runR2Input @(RoutedFrom (Maybe NodeHandshake)) defaultAddr | ||
| $ forever (acceptR2 >>= pnetnd nodeID) | ||
| ) | ||
| trace (Text.printf "%s disconnected from `%s`" nodeIDStr (show transport)) | ||
| whenJust maybeNodeID (stateDeleteNode . entry) | ||
| where | ||
| nodeIDStr = maybe "unknown node" show maybeNodeID | ||
| entry nodeID = (s, nodeID) | ||
|
|
||
| pnetcd :: (Members (TransportEffects Handshake Response) r, Members (TransportEffects (RoutedFrom (Maybe (RoutedFrom (Maybe ByteString)))) (RouteTo (Maybe (RouteTo (Maybe ByteString))))) r, Member (AtomicState (State s)) r, Member Trace r, Eq s) => s -> Sem r () | ||
| pnetcd = traceTagged "pnetcd" . handle . go | ||
| pnetcd :: | ||
| ( Members (TransportEffects Handshake Response) r, | ||
| Members (TransportEffects (RoutedFrom (Maybe (RoutedFrom Connection))) (RouteTo (Maybe (RouteTo Connection)))) r, | ||
| Members (TransportEffects (RoutedFrom (Maybe (RoutedFrom (Maybe ByteString)))) (RouteTo (Maybe (RouteTo (Maybe ByteString))))) r, | ||
| Member (Sockets (RoutedFrom (Maybe (RouteTo ByteString))) (RouteTo (Maybe (RoutedFrom ByteString))) s) r, | ||
| Member (Sockets (RouteTo ByteString) (RoutedFrom ByteString) s) r, | ||
| Member (InputWithEOF (RoutedFrom (Maybe (RoutedFrom (Maybe NodeHandshake))))) r, | ||
| Member (InputWithEOF (RoutedFrom (Maybe (RouteTo ByteString)))) r, | ||
| Member (InputWithEOF (RouteTo ByteString)) r, | ||
| Member (Output (RouteTo (Maybe (RouteTo (Maybe NodeHandshake))))) r, | ||
| Member (AtomicState (State s)) r, | ||
| Member Trace r, | ||
| Eq s | ||
| ) => | ||
| s -> | ||
| Sem r () | ||
| pnetcd s = handle \case | ||
| ListNodes -> listNodes | ||
| (ConnectNode transport maybeNodeID) -> connectNode s transport maybeNodeID | ||
| Route sender -> | ||
| let entry = (s, sender) | ||
| in stateAddNode entry >> route runClientOutput sender >> stateDeleteNode entry | ||
| where | ||
| go _ ListNodes = traceTagged "ListNodes" do | ||
| nodeList <- map snd <$> atomicGet | ||
| trace (Text.printf "responding with `%s`" (show nodeList)) | ||
| output (NodeList nodeList) | ||
| go s (ConnectNode transport maybeNodeID) = traceTagged "connection" do | ||
| trace (Text.printf "%s connected over `%s`" nodeIDStr (show transport)) | ||
| whenJust maybeNodeID (atomicModify' . (:) . entry) | ||
| traceTagged "pnetnd" . trace . show =<< runFail (runR2 defaultAddr pnetnd) | ||
| trace (Text.printf "%s disconnected from `%s`" nodeIDStr (show transport)) | ||
| whenJust maybeNodeID (atomicModify' . List.delete . entry) | ||
| where | ||
| nodeIDStr = maybe "unknown node" show maybeNodeID | ||
| entry nodeID = (s, nodeID) | ||
| runClientOutput s = socketOutput s . runR2Output defaultAddr . raiseUnder @(Output (RouteTo (Maybe (RoutedFrom ByteString)))) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Oops, something went wrong.