From e9a85a3a67f66e7e5a53c46d37ac217b3205cca9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 26 Oct 2022 16:47:24 +0200 Subject: [PATCH 001/229] Added additional debugging info --- exe/Main.hs | 3 +++ exe/Output.hs | 5 +++++ 2 files changed, 8 insertions(+) diff --git a/exe/Main.hs b/exe/Main.hs index c96b9c6..acb3607 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -252,6 +252,9 @@ parseFile mpath = do (name, src) <- liftIO $ case mpath of Nothing -> ("",) <$> getContents Just fp -> (fp,) <$> readFile fp + + -- Print declarations for debug + msgInfo . show $ parseDecls src case parseDecls src of Left err -> Nothing <$ formatMsg MsgError (Just name) err diff --git a/exe/Output.hs b/exe/Output.hs index 689ef8e..7f63318 100644 --- a/exe/Output.hs +++ b/exe/Output.hs @@ -46,6 +46,7 @@ stderrColumns = liftIO $ fmap Terminal.width <$!> size data MsgLevel = MsgError | MsgWarning + | MsgInfo msgWarning :: (MonadReader TerminalSize m, MonadIO m) => String -> m () msgWarning = formatMsg MsgWarning Nothing @@ -53,12 +54,16 @@ msgWarning = formatMsg MsgWarning Nothing msgFatal :: (MonadReader TerminalSize m, MonadIO m) => String -> m a msgFatal msg = formatMsg MsgError Nothing msg >> liftIO exitFailure +msgInfo :: (MonadReader TerminalSize m, MonadIO m) => String -> m () +msgInfo = formatMsg MsgInfo Nothing + formatMsg :: (MonadIO m, MonadReader TerminalSize m) => MsgLevel -> Maybe FilePath -> String -> m () formatMsg level mfile msg = do let levelDoc = let (levelString, color) = case level of MsgError -> ("error", Terminal.Red) MsgWarning -> ("warning", Terminal.Yellow) + MsgInfo -> ("info", Terminal.White) in annotate (Terminal.color color) $ levelString <> ": " let fileDoc = flip foldMap mfile \file -> From 59fcc391c86526594f819811549db211e033ea33 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 26 Oct 2022 18:34:08 +0200 Subject: [PATCH 002/229] More debug info --- src/Config.hs | 4 ++-- src/Interpreter.hs | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Config.hs b/src/Config.hs index 84b948b..fa6467f 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -12,8 +12,8 @@ data DebugLevel = DebugNone | DebugAll deriving (Eq, Ord, Show) debugLevel :: DebugLevel ---debugLevel = DebugAll -debugLevel = DebugNone +debugLevel = DebugAll +-- debugLevel = DebugNone trace :: String -> a -> a trace s a | debugLevel > DebugNone = D.trace s a diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 575e9b8..a41c524 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -135,11 +135,11 @@ eval = \case r <- liftIO Chan.newChan w <- liftIO Chan.newChan return $ VPair (VChan r w) (VChan w r) - Send e -> VSend <$> interpret' e + Send e -> VSend <$> interpret' e -- Apply VSend to the output of interpret' e Recv e -> do interpret' e >>= \v@(VChan c _) -> do val <- liftIO $ Chan.readChan c - liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan " + liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e return $ VPair val v Case e cases -> interpret' e >>= \(VLabel s) -> interpret' $ fromJust $ lookup s cases e -> throw $ NotImplementedException e From a08e84e39da4abacd698a644e41c4271bde47a7a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 9 Nov 2022 11:51:01 +0100 Subject: [PATCH 003/229] First serialization and deserialization test --- ldgv.cabal | 4 +- src/Interpreter.hs | 21 +++++- src/ProcessEnvironment.hs | 2 +- src/ValueParsing/ValueGrammar.y | 86 +++++++++++++++++++++ src/ValueParsing/ValueTokens.x | 128 ++++++++++++++++++++++++++++++++ 5 files changed, 235 insertions(+), 6 deletions(-) create mode 100644 src/ValueParsing/ValueGrammar.y create mode 100644 src/ValueParsing/ValueTokens.x diff --git a/ldgv.cabal b/ldgv.cabal index c9c020d..4c21492 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.34.6. -- -- see: https://github.com/sol/hpack @@ -71,6 +71,8 @@ library ProcessEnvironment Syntax Typechecker + ValueParsing.ValueGrammar + ValueParsing.ValueTokens other-modules: PrettySyntax TCSubtyping diff --git a/src/Interpreter.hs b/src/Interpreter.hs index a41c524..930a261 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -22,6 +22,9 @@ import Control.Applicative ((<|>)) import Control.Exception import Kinds (Multiplicity(..)) +import qualified ValueParsing.ValueTokens as VT +import qualified ValueParsing.ValueGrammar as VG + data InterpreterException = MathException String | LookupException String @@ -31,6 +34,7 @@ data InterpreterException | RecursorNotNatException | NotImplementedException Exp | TypeNotImplementedException Type + | DeserializationException String deriving Eq instance Show InterpreterException where @@ -43,6 +47,7 @@ instance Show InterpreterException where RecursorNotNatException -> "Recursor only works on natural numbers" (NotImplementedException exp) -> "NotImplementedException: " ++ pshow exp (TypeNotImplementedException typ) -> "TypeNotImplementedException: " ++ pshow typ + (DeserializationException err) -> "DeserializationException: " ++ err instance Exception InterpreterException @@ -138,9 +143,16 @@ eval = \case Send e -> VSend <$> interpret' e -- Apply VSend to the output of interpret' e Recv e -> do interpret' e >>= \v@(VChan c _) -> do - val <- liftIO $ Chan.readChan c - liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e - return $ VPair val v + -- case ((flip VT.runAlex VG.parseValues) (head (liftIO $ Chan.readChan c))) of + -- clo <- liftIO $ Chan.readChan c + chanString <- liftIO $ Chan.readChan c + + case VT.runAlex chanString VG.parseValues of + Left err -> throw $ DeserializationException err + Right val -> + -- Translate Value Strings back into Values + -- liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan" -- , over expression " ++ show e + return $ VPair val v Case e cases -> interpret' e >>= \(VLabel s) -> interpret' $ fromJust $ lookup s cases e -> throw $ NotImplementedException e @@ -175,7 +187,8 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) | n > 0 = do let env' = extendEnv n1 (VInt (n-1)) (extendEnv f natrec env) R.local (const env') (interpret' es) -interpretApp _ (VSend v@(VChan _ c)) w = liftIO (Chan.writeChan c w) >> return v +interpretApp _ (VSend v@(VChan _ c)) w = liftIO (Chan.writeChan c (show w)) >> return v +-- Convert the Values to Strings interpretApp e _ _ = throw $ ApplicationException e interpretLit :: Literal -> Value diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index e831b3c..2dad8c1 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -39,7 +39,7 @@ data Value | VString String -- we have two channels, one for reading and one for writing to the other -- end, so we do not read our own written values - | VChan (C.Chan Value) (C.Chan Value) + | VChan (C.Chan String) (C.Chan String) | VSend Value | VPair Value Value -- pair of ids that map to two values | VType S.Type diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y new file mode 100644 index 0000000..17b4079 --- /dev/null +++ b/src/ValueParsing/ValueGrammar.y @@ -0,0 +1,86 @@ +{ +module ValueParsing.ValueGrammar (parseValues) where + +import Control.Monad +import qualified Data.List as List + +import Kinds +-- import Syntax +import ProcessEnvironment +import ValueParsing.ValueTokens (T(..)) +import qualified ValueParsing.ValueTokens as T +} + +%monad { T.Alex } +%lexer { (\f -> T.alexMonadScan >>= f) } { T _ T.EOF } +%error { parseError } +%tokentype { T } + +--%name parseDecls Cmds +--%name parseType Typ + +%name parseValues Values + +%token + vunit { T _ T.VUnitN } + vlabel { T _ T.VLabelN } + vint { T _ T.VIntN } + vdouble { T _ T.VDoubleN } + vstring { T _ T.VStringN } + vpair { T _ T.VPairN } + vgreater { T _ T.GreaterN } + vlesser { T _ T.LesserN } + vcomma { T _ T.CommaN } + vparopen { T _ T.ParOpenN } + vparclose { T _ T.ParCloseN } + vsend { T _ T.VSendN } + + int { T _ (T.Int $$) } + double { T _ (T.Double $$) } + string { T _ (T.String $$) } + label { T _ (T.Label $$) } + +--%right LET +--%nonassoc int double '(' var lab case natrec '()' lam rec fst snd new fork +--%right in +--%nonassoc '>' '<' +--%left '+' '-' NEG POS +--%left '*' '/' +--%left send recv +--%nonassoc APP + + +%% + +-- Values : {[]} +-- | vunit { VUnit } +Values : vunit { VUnit } + | vlabel label {VLabel $2} + | vint int {VInt $2} + | vdouble double {VDouble $2} + | vstring string {VString (trimQuote(trimQuote $2)) } + | vpair vlesser Values vcomma Values vgreater {VPair $3 $5} + | vsend vparopen Values vparclose {VSend $3} + +{ + + +parseError (T (T.AlexPn _ line column) t) = do + nextTokens <- filter (/= T.EOF) . (t:) <$> replicateM 9 (tokVal <$> T.alexMonadScan) + let err | null nextTokens = "parse error: unexpected end of file" + | otherwise = mconcat + [ "parse error at line " + , show line + , ", column " + , show column + , ": unexpected token" + , if null (tail nextTokens) then " " else "s " + , List.intercalate ", " $ showToken <$> nextTokens + ] + T.alexError err + +showToken t = "›" ++ show t ++ "‹" + +trimQuote :: String -> String +trimQuote (_:xs) = init xs +} diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x new file mode 100644 index 0000000..34e202b --- /dev/null +++ b/src/ValueParsing/ValueTokens.x @@ -0,0 +1,128 @@ +{ +{-# LANGUAGE BlockArguments #-} +module ValueParsing.ValueTokens + ( -- * Tokens + Token(..) + , AlexPosn(..) + , T(..) + + -- * Alex monad + , Alex + , runAlex + , alexMonadScan + , alexError + , scanner + ) where + +import Kinds +import Text.Read (readMaybe) +} + +%wrapper "monad" +-- %wrapper "monadUserState" +-- %wrapper "basic" + +$digit = 0-9 -- digits +$alpha = [a-zA-Z] -- alphabetic characters +$lower = [a-z] +$upper = [A-Z] + +tokens :- + + $white+ ; + VUnit { tok $ const VUnitN } + VLabel { tok $ const VLabelN} + VInt { tok $ const VIntN} + VString { tok $ const VStringN} + VPair { tok $ const VPairN} + VSend { tok $ const VSendN} + $digit+ "." $digit+ { tok $ Double . read } + $digit+ { tok $ Int . read } + \"\"[^\"]*\"\" { tok $ String } + "<" { tok $ const LesserN } + ">" { tok $ const GreaterN } + "," { tok $ const CommaN } + "(" { tok $ const ParOpenN } + ")" { tok $ const ParCloseN } + $alpha [$alpha $digit \_ \']* { tok $ Label } + +{ +-- The token type: +-- | (Unit, Label, Int, Values of self-declared Data Types), Channels +data Token + = VUnitN + | VLabelN + | VIntN + | VDoubleN + | VStringN + | VSendN + | VPairN + | Label String + | String String + | Int Int + | Double Double + | GreaterN + | LesserN + | CommaN + | ParOpenN + | ParCloseN + | EOF + deriving (Eq, Show) + +data T = T { tokPos :: AlexPosn, tokVal :: !Token } + deriving (Eq, Show) + +alexEOF :: Alex T +alexEOF = do + (pos, _, _, _) <- alexGetInput + pure $ T pos EOF + +tok :: (String -> Token) -> AlexAction T +tok f = tok' (Right . f) + +tok' :: (String -> Either String Token) -> AlexAction T +tok' f (pos@(AlexPn _ line column), _, _, inp) len = do + let inp' = take len inp + case f inp' of + Left err -> alexError $ mconcat + [ "lexical error at line " + , show line + , ", column " + , show column + , if null err then "" else (": " ++ err) + ] + Right tok -> pure $ T pos tok + +{- +tokKind :: AlexAction T +tokKind = tok' \k -> + maybe (Left $ "invalid kind " ++ k) (Right . Kind) + $ readMaybe + $ ('K':) -- Subsitutes the initial '~' with 'K' + $ tail k + + -} + +-- runAlexScan :: String -> Either ParseError AlexUserState +{-scanner str = runAlex str $ do + let loop i = do tok <- alexMonadScan + if (tokVal tok) == EOF then return i + else do let i' = i+1 in i' `seq` loop i' + loop 0-} + +{-scanner str = runAlex str $ do + let loop i = do tok <- alexMonadScan; + if (tokVal tok) == EOF + then return i + else do loop $! (i+1) + loop 0-} + +scanner str = runAlex str $ do + let loop i = do tok <- alexMonadScan; + if (tokVal tok) == EOF + then return i + else do loop $! (i++[(tokVal tok)]) + loop [] +} + +-- https://gist.github.com/m1dnight/126d6b500175c2c286e3804584e5c4ce \ No newline at end of file From 0131ad3506b0c04f91b5066daec9849011c587ce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 9 Nov 2022 11:55:55 +0100 Subject: [PATCH 004/229] Update Interpreter.hs --- src/Interpreter.hs | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 930a261..0b0a4a7 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -143,15 +143,12 @@ eval = \case Send e -> VSend <$> interpret' e -- Apply VSend to the output of interpret' e Recv e -> do interpret' e >>= \v@(VChan c _) -> do - -- case ((flip VT.runAlex VG.parseValues) (head (liftIO $ Chan.readChan c))) of - -- clo <- liftIO $ Chan.readChan c chanString <- liftIO $ Chan.readChan c - case VT.runAlex chanString VG.parseValues of + -- Translate Value Strings back into Values Left err -> throw $ DeserializationException err - Right val -> - -- Translate Value Strings back into Values - -- liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan" -- , over expression " ++ show e + Right val -> do + liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e return $ VPair val v Case e cases -> interpret' e >>= \(VLabel s) -> interpret' $ fromJust $ lookup s cases e -> throw $ NotImplementedException e From e7a192661e7c265c4014f3333b6077d08544b5f8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 9 Nov 2022 14:32:59 +0100 Subject: [PATCH 005/229] Update ProcessEnvironment.hs --- src/ProcessEnvironment.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index 2dad8c1..c023848 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -30,6 +30,9 @@ data FuncType = FuncType PEnv String S.Type S.Type instance Show FuncType where show (FuncType _ s t1 t2) = "FuncType " ++ show s ++ " " ++ show t1 ++ " " ++ show t2 + +type ValueRepr = String + -- | (Unit, Label, Int, Values of self-declared Data Types), Channels data Value = VUnit @@ -39,7 +42,7 @@ data Value | VString String -- we have two channels, one for reading and one for writing to the other -- end, so we do not read our own written values - | VChan (C.Chan String) (C.Chan String) + | VChan (C.Chan ValueRepr) (C.Chan ValueRepr) | VSend Value | VPair Value Value -- pair of ids that map to two values | VType S.Type From 5cbc874d37b847fa773eb7605eb759a4968f5e59 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 16 Nov 2022 16:20:55 +0100 Subject: [PATCH 006/229] Updated Value(De)Serialization --- ldgv.cabal | 3 +- src/Interpreter.hs | 3 +- src/SerializeValues.hs | 163 +++++++++++++++++++ src/ValueParsing/ValueGrammar.y | 266 +++++++++++++++++++++++++++++--- src/ValueParsing/ValueTokens.x | 228 +++++++++++++++++++++++---- 5 files changed, 609 insertions(+), 54 deletions(-) create mode 100644 src/SerializeValues.hs diff --git a/ldgv.cabal b/ldgv.cabal index 4c21492..7ac97cb 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.34.6. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack @@ -69,6 +69,7 @@ library Parsing.Grammar Parsing.Tokens ProcessEnvironment + SerializeValues Syntax Typechecker ValueParsing.ValueGrammar diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 0b0a4a7..42b60ee 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -21,6 +21,7 @@ import Control.Monad.Reader as R import Control.Applicative ((<|>)) import Control.Exception import Kinds (Multiplicity(..)) +import qualified SerializeValues as SV import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG @@ -184,7 +185,7 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) | n > 0 = do let env' = extendEnv n1 (VInt (n-1)) (extendEnv f natrec env) R.local (const env') (interpret' es) -interpretApp _ (VSend v@(VChan _ c)) w = liftIO (Chan.writeChan c (show w)) >> return v +interpretApp _ (VSend v@(VChan _ c)) w = liftIO (Chan.writeChan c (SV.serialize w)) >> return v -- Convert the Values to Strings interpretApp e _ _ = throw $ ApplicationException e diff --git a/src/SerializeValues.hs b/src/SerializeValues.hs new file mode 100644 index 0000000..3f6f677 --- /dev/null +++ b/src/SerializeValues.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} + +module SerializeValues where + +import ProcessEnvironment +import Syntax +import Kinds +import qualified Syntax as S +import Data.Set + +class Serializable a where + serialize :: a -> String + +instance Serializable Value where + serialize = \case + VUnit -> "VUnit" + VLabel s -> "VLabel (" ++ serialize s ++ ")" + VInt i -> "VInt (" ++ serialize i ++ ")" + VDouble d -> "VDouble (" ++ serialize d ++ ")" + VString s -> "VString (" ++ serialize s ++ ")" + VChan _ _ -> "VChan" + VSend v -> "VSend (" ++ serialize v ++ ")" + VPair a b -> "VPair (" ++ serialize a ++ ") (" ++ serialize b ++ ")" + VType t -> "VType (" ++ serialize t ++ ")" + VFunc env s exp -> "VFunc (" ++ serialize env ++ ") (" ++ serialize s ++ ") (" ++ serialize exp++")" + VDynCast v t -> "VDynCast (" ++ serialize v ++ ") (" ++ serialize t ++ ")" + VFuncCast v ft1 ft2 -> "VFuncCast (" ++ serialize v ++ ") (" ++ serialize ft1 ++ ") (" ++ serialize ft2 ++ ")" + VRec env f x e1 e0 -> "VRec (" ++ serialize env ++") (" ++ serialize f ++ ") (" ++ serialize x ++ ") (" ++ serialize e1 ++ ") (" ++ serialize e0 ++ ")" + VNewNatRec env f n tid ty ez x es -> "VNewNatRec (" ++ serialize env ++ ") (" ++ serialize f ++ ") (" ++ serialize n ++ ") (" ++ serialize tid ++ + ") (" ++ serialize ty ++ ") (" ++ serialize ez ++ ") (" ++ serialize x ++ ") ("++ serialize es++ ")" + +instance Serializable Type where + serialize = \case + TUnit -> "TUnit" + TInt -> "TInt" + TDouble -> "TDouble" + TBot -> "TBot" + TDyn -> "TDyn" + TNat -> "TNat" + TString -> "TString" + TNatLeq i -> "TNatLeq (" ++ serialize i ++ ")" + TNatRec e t1 ident t2 -> "TNatRec (" ++ serialize e ++") (" ++ serialize t1 ++ ") (" ++ serialize ident ++ ") (" ++ serialize t2 ++ ")" + TVar b ident -> "TVar (" ++ serialize b ++ ") (" ++ serialize ident ++ ")" + TAbs ident t1 t2 -> "TAbs (" ++ serialize ident ++ ") (" ++ serialize t1 ++ ") (" ++ serialize t2 ++ ")" + TName b ident -> "TName (" ++ serialize b ++ ") (" ++ serialize ident ++ ")" + TLab arr -> "TLab (" ++ serialize arr ++ ")" + TFun mult ident t1 t2 -> "TFun (" ++ show mult ++ ") (" ++ serialize ident ++ ") (" ++ serialize t1 ++ ") (" ++ serialize t2 ++ ")" + TPair ident t1 t2 -> "TPair (" ++ serialize ident ++ ") (" ++ serialize t1 ++ ") (" ++ serialize t2 ++ ")" + TSend ident t1 t2 -> "TSend (" ++ serialize ident ++ ") (" ++ serialize t1 ++ ") (" ++ serialize t2 ++ ")" + TRecv ident t1 t2 -> "TRecv (" ++ serialize ident ++ ") (" ++ serialize t1 ++ ") (" ++ serialize t2 ++ ")" + TCase e arr -> "TCase (" ++ serialize e ++ ") (" ++ serialize arr ++ ")" + TEqn e1 e2 t -> "TEqn (" ++ serialize e1 ++ ") (" ++ serialize e2 ++ ") (" ++ serialize t ++ ")" + TSingle ident -> "TSingle (" ++ serialize ident ++ ")" + +instance Serializable Exp where + serialize = \case + Let ident e1 e2 -> "ELet (" ++ serialize ident ++ ") (" ++ serialize e1 ++ ") (" ++ serialize e2 ++ ")" + Math mathop -> "EMath (" ++ serialize mathop ++ ")" + Lit l -> "ELit (" ++ serialize l ++ ")" + Succ e -> "ESucc (" ++ serialize e ++ ")" + NatRec e1 e2 ident1 ident2 ident3 t e3 -> "ENatRec (" ++ serialize e1 ++ ") (" ++ serialize e2 ++ ") (" ++ serialize ident1 ++ + ") (" ++ serialize ident2 ++ ") (" ++ serialize ident3 ++ ") (" ++ serialize t ++ + ") (" ++ serialize e3 ++ ")" + NewNatRec ident1 ident2 ident3 t e1 ident4 e2 -> "ENetNatRec (" ++ serialize ident1 ++ ") (" ++ serialize ident2 ++ + ") (" ++ serialize ident3++ ") (" ++ serialize t ++ ") (" ++ serialize e1 ++ + ") (" ++ serialize ident4 ++ ") (" ++ serialize e2 ++ ")" + Var ident -> "EVar (" ++ serialize ident ++ ")" + Lam mult ident t e -> "ELam (" ++ show mult ++ ") (" ++ serialize ident ++ ") (" ++ serialize t ++ ") (" ++ serialize e ++ ")" + Rec ident1 ident2 e1 e2 -> "ERec (" ++ serialize ident1 ++ ") (" ++ serialize ident2 ++ ") (" ++ serialize e1 ++ + ") (" ++ serialize e2 ++ ")" + App e1 e2 -> "EApp (" ++ serialize e1 ++ ") (" ++ serialize e2 ++ ")" + Pair mult ident e1 e2 -> "EPair (" ++ show mult ++ ") (" ++ serialize ident ++ ") (" ++ serialize e1 ++ + ") (" ++ serialize e2 ++ ")" + LetPair ident1 ident2 e1 e2 -> "ELetPair (" ++ serialize ident1 ++ ") (" ++ serialize ident2 ++ ") (" ++ serialize e1 ++ + ") (" ++ serialize e2 ++ ")" + Fst e -> "EFst (" ++ serialize e ++ ")" + Snd e -> "ESnd (" ++ serialize e ++ ")" + Fork e -> "EFork (" ++ serialize e ++ ")" + New t -> "ENew (" ++ serialize t ++ ")" + Send e -> "ESend (" ++ serialize e ++ ")" + Recv e -> "ERecv (" ++ serialize e ++ ")" + Case e arr -> "ECase (" ++ serialize e ++ ") (" ++ serialize arr ++ ")" + Cast e t1 t2 -> "ECast (" ++ serialize e ++ ") (" ++ serialize t1 ++ ") (" ++ serialize t2 ++ ")" + +instance Serializable (MathOp Exp) where + serialize = \case + Add e1 e2 -> "MAdd (" ++ serialize e1 ++ ") (" ++ serialize e2 ++ ")" + Sub e1 e2 -> "MSub (" ++ serialize e1 ++ ") (" ++ serialize e2 ++ ")" + Mul e1 e2 -> "MMul (" ++ serialize e1 ++ ") (" ++ serialize e2 ++ ")" + Div e1 e2 -> "MDiv (" ++ serialize e1 ++ ") (" ++ serialize e2 ++ ")" + Neg e -> "MNeg (" ++ serialize e ++ ")" + +instance Serializable Literal where + serialize = \case + LInt i -> "LInt (" ++ serialize i ++ ")" + LNat i -> "LNat (" ++ serialize i ++ ")" + LDouble d -> "LDouble (" ++ serialize d ++ ")" + LLab s -> "LLab (" ++ serialize s ++ ")" + LUnit -> "LUnit" + LString s -> "LString (" ++ serialize s ++ ")" + +instance Serializable FuncType where + serialize (FuncType env s t1 t2) = "SFuncType (" ++ serialize env ++ ") (" ++ serialize s ++ ") (" ++ serialize t1 ++ ") (" ++ serialize t2 ++ ")" + +instance Serializable GType where + serialize = \case + GUnit -> "GUnit" + GLabel lt -> "GLabel (" ++ serialize lt ++ ")" + GFunc mult -> "GFunc (" ++ show mult ++ ")" + GPair -> "GPair" + GNat -> "GNat" + GNatLeq i -> "GNatLeq (" ++ serialize i ++ ")" + GInt -> "GInt" + GDouble -> "GDouble" + GString -> "GString" + +instance {-# OVERLAPPING #-} Serializable String where + serialize s = "String:"++ show s + +instance Serializable Int where + serialize i = "Int:" ++ show i + +instance Serializable Integer where + serialize i = "Integer:" ++ show i + +instance Serializable Bool where + serialize b = "Bool:" ++ show b + +instance Serializable Double where + serialize d = "Double:" ++ show d + +instance (Serializable a => Serializable (Set a)) where + serialize as = "{" ++ serializeElements (elems as) ++ "}" + +instance {-# OVERLAPPABLE #-} (Serializable a => Serializable [a]) where + serialize arr = "["++ serializeElements arr ++"]" + +instance ((Serializable a, Serializable b) => Serializable (a, b)) where + serialize (s, t) = "((" ++ serialize s ++ ") (" ++ serialize t ++ "))" + +instance {-# OVERLAPPING #-} Serializable PEnv where + serialize arr = "PEnv ["++ serializeElements arr ++"]" + +instance {-# OVERLAPPING #-} Serializable PEnvEntry where + serialize (s, t) = "PEnvEntry (" ++ serialize s ++ ") (" ++ serialize t ++ ")" + +instance {-# OVERLAPPING #-} Serializable LabelType where + serialize as = "SLabelType {" ++ serializeElements (elems as) ++ "}" + +instance {-# OVERLAPPING #-} Serializable [(String, Exp)] where + serialize arr = "SStringExpArray [" ++ serializeElements arr ++ "]" + +instance {-# OVERLAPPING #-} Serializable [(String, Type)] where + serialize arr = "SStringTypeArray [" ++ serializeElements arr ++ "]" + +instance {-# OVERLAPPING #-} Serializable [String] where + serialize arr = "SStringArray [" ++ serializeElements arr ++ "]" + +serializeElements :: Serializable a => [a] -> String +serializeElements [] = "" +serializeElements [x] = serialize x +serializeElements (x:xs) = serialize x ++ ", " ++ serializeElements xs \ No newline at end of file diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 17b4079..3c09859 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -3,9 +3,10 @@ module ValueParsing.ValueGrammar (parseValues) where import Control.Monad import qualified Data.List as List +import qualified Data.Set as Set import Kinds --- import Syntax +import Syntax import ProcessEnvironment import ValueParsing.ValueTokens (T(..)) import qualified ValueParsing.ValueTokens as T @@ -20,25 +21,127 @@ import qualified ValueParsing.ValueTokens as T --%name parseType Typ %name parseValues Values +-- %name parseSStringTypeElement SStringTypeElement +-- %name parseSStringTypeElements SStringTypeElements +-- %name parseSStringTypeArray SStringTypeArray %token - vunit { T _ T.VUnitN } - vlabel { T _ T.VLabelN } - vint { T _ T.VIntN } - vdouble { T _ T.VDoubleN } - vstring { T _ T.VStringN } - vpair { T _ T.VPairN } - vgreater { T _ T.GreaterN } - vlesser { T _ T.LesserN } - vcomma { T _ T.CommaN } - vparopen { T _ T.ParOpenN } - vparclose { T _ T.ParCloseN } - vsend { T _ T.VSendN } - - int { T _ (T.Int $$) } - double { T _ (T.Double $$) } - string { T _ (T.String $$) } - label { T _ (T.Label $$) } + vunit { T _ T.VUnit } + vlabel { T _ T.VLabel } + vint { T _ T.VInt } + vdouble { T _ T.VDouble } + vstring { T _ T.VString } + vchan { T _ T.VChan} + vsend { T _ T.VSend } + vpair { T _ T.VPair } + vtype { T _ T.VType } + vfunc { T _ T.VFunc } + vdyncast { T _ T.VDynCast } + vfunccast { T _ T.VFuncCast } + vrec { T _ T.VRec } + vnewnatrec { T _ T.VNewNatRec } + + tunit { T _ T.TUnit } + tint { T _ T.TInt } + tdouble { T _ T.TDouble } + tbot { T _ T.TBot } + tdyn { T _ T.TDyn } + tnat { T _ T.TNat } + tstring { T _ T.TString } + tnatleq { T _ T.TNatLeq } + tnatrec { T _ T.TNatRec } + tvar { T _ T.TVar } + tabs { T _ T.TAbs } + tname { T _ T.TName } + tlab { T _ T.TLab } + tfun { T _ T.TFun } + tpair { T _ T.TPair } + tsend { T _ T.TSend } + trecv { T _ T.TRecv } + tcase { T _ T.TCase } + teqn { T _ T.TEqn } + tsingle { T _ T.TSingle } + + elet { T _ T.ELet } + emath { T _ T.EMath } + elit { T _ T.ELit } + esucc { T _ T.ESucc } + enatrec { T _ T.ENatRec } + enewnatrec { T _ T.ENewNatRec } + evar { T _ T.EVar } + elam { T _ T.ELam } + erec { T _ T.ERec } + eapp { T _ T.EApp } + epair { T _ T.EPair } + eletpair { T _ T.ELetPair } + efst { T _ T.EFst } + esnd { T _ T.ESnd } + efork { T _ T.EFork } + enew { T _ T.ENew } + esend { T _ T.ESend } + erecv { T _ T.ERecv } + ecase { T _ T.ECase } + ecast { T _ T.ECast } + + madd { T _ T.MAdd } + msub { T _ T.MSub } + mmul { T _ T.MMul } + mdiv { T _ T.MDiv } + mneg { T _ T.MNeg } + + mone { T _ T.MOne } + mmany { T _ T.MMany } + + lint { T _ T.LInt } + lnat { T _ T.LNat } + ldouble { T _ T.LDouble } + llab { T _ T.LLab } + lunit { T _ T.LUnit } + lstring { T _ T.LString } + + sfunctype { T _ T.SFuncType } + slabeltype { T _ T.SLabelType } + sstringexparray { T _ T.SStringExpArray } + sstringtypearray { T _ T.SStringTypeArray } + sstringarray { T _ T.SStringArray } + + gunit { T _ T.GUnit } + glabel { T _ T.GLabel } + gfunc { T _ T.GFunc } + gpair { T _ T.GPair } + gnat { T _ T.GNat } + gnatleq { T _ T.GNatLeq } + gint { T _ T.GInt } + gdouble { T _ T.GDouble } + gstring { T _ T.GString } + + penv { T _ T.PEnv } + penventry { T _ T.PEnvEntry } + + + int { T _ (T.Int $$) } + integer { T _ (T.Integer $$) } + double { T _ (T.Double $$) } + string { T _ (T.String $$) } + bool { T _ (T.Bool $$) } + + '{' { T _ (T.Sym '{') } + '}' { T _ (T.Sym '}') } +-- '=' { T _ (T.Sym '=') } +-- '+' { T _ (T.Sym '+') } +-- '-' { T _ (T.Sym '-') } +-- '*' { T _ (T.Sym '*') } +-- '/' { T _ (T.Sym '/') } + '(' { T _ (T.Sym '(') } + ')' { T _ (T.Sym ')') } +-- '<' { T _ (T.Sym '<') } +-- '>' { T _ (T.Sym '>') } + '[' { T _ (T.Sym '[') } + ']' { T _ (T.Sym ']') } +-- '!' { T _ (T.Sym '!') } +-- '?' { T _ (T.Sym '?') } +-- '"' { T _ (T.Sym '"') } + ',' { T _ (T.Sym ',') } --%right LET --%nonassoc int double '(' var lab case natrec '()' lam rec fst snd new fork @@ -55,12 +158,127 @@ import qualified ValueParsing.ValueTokens as T -- Values : {[]} -- | vunit { VUnit } Values : vunit { VUnit } - | vlabel label {VLabel $2} - | vint int {VInt $2} - | vdouble double {VDouble $2} - | vstring string {VString (trimQuote(trimQuote $2)) } - | vpair vlesser Values vcomma Values vgreater {VPair $3 $5} - | vsend vparopen Values vparclose {VSend $3} + | vlabel '(' String ')' {VLabel $3 } + | vint '(' int ')' {VInt $3} + | vdouble '(' double ')' {VDouble $3} + | vstring '(' String ')' {VString $3 } +-- | vchan {VChan "" "" } + | vsend '(' Values ')' {VSend $3} + | vpair '(' Values ')' '(' Values ')' {VPair $3 $6} + | vtype '(' Type ')' {VType $3} + | vfunc '(' PEnv ')' '(' String ')' '(' Exp ')' {VFunc $3 $6 $9} + | vdyncast '(' Values ')' '(' GType ')' {VDynCast $3 $6} + | vfunccast '(' Values ')' '(' SFuncType ')' '(' SFuncType ')' {VFuncCast $3 $6 $9} + | vrec '(' PEnv ')' '(' String ')' '(' String ')' '(' Exp ')' '(' Exp ')' {VRec $3 $6 $9 $12 $15} + | vnewnatrec '(' PEnv ')' '(' String ')' '(' String ')' '(' String ')' '(' Type ')' '(' Exp ')' '(' String ')' '(' Exp ')' {VNewNatRec $3 $6 $9 $12 $15 $18 $21 $24} + +String : string {trimQuote $1} + + +Mult : mone { MOne } + | mmany { MMany } + +Literal : lint '(' int ')' {LInt $3} + | lnat '(' int ')' {LNat $3} + | ldouble '(' double ')' {LDouble $3} + | llab '(' String ')' {LLab $3} + | lunit {LUnit} + | lstring '(' String ')' {LLab $3} + +SFuncType : sfunctype '(' PEnv ')' '(' String ')' '(' Type ')' '(' Type ')' {FuncType $3 $6 $9 $12} + +Type : tunit {TUnit} + | tint {TInt} + | tdouble {TDouble} + | tbot {TBot} + | tdyn {TDyn} + | tnat {TNat} + | tstring {TString} + | tnatleq '(' integer ')' {TNatLeq $3} + | tnatrec '(' Exp ')' '(' Type ')' '(' String ')' '(' Type ')' {TNatRec $3 $6 $9 $12} + | tvar '(' bool ')' '(' String ')' {TVar $3 $6} + | tabs '(' String ')' '(' Type ')' '(' Type ')' {TAbs $3 $6 $9} + | tname '(' bool ')' '(' String ')' {TName $3 $6} + | tlab '(' SStringArray ')' {TLab $3} + | tfun '(' Mult ')' '(' String ')' '(' Type ')' '(' Type ')' {TFun $3 $6 $9 $12} + | tpair '(' String ')' '(' Type ')' '(' Type ')' {TPair $3 $6 $9} + | tsend '(' String ')' '(' Type ')' '(' Type ')' {TSend $3 $6 $9} + | trecv '(' String ')' '(' Type ')' '(' Type ')' {TRecv $3 $6 $9} + | tcase '(' Exp ')' '(' SStringTypeArray ')' {TCase $3 $6} + | teqn '(' Exp ')' '(' Exp ')' '(' Type ')' {TEqn $3 $6 $9} + | tsingle '(' String ')' {TSingle $3} + +Exp : elet '(' String ')' '(' Exp ')' '(' Exp ')' {Let $3 $6 $9} + | emath '(' MathOp ')' {Math $3} + | elit '(' Literal ')' {Lit $3} + | esucc '(' Exp ')' {Succ $3} + | enatrec '(' Exp ')' '(' Exp ')' '(' String ')' '(' String ')' '(' String ')' '(' Type ')' '(' Exp ')' {NatRec $3 $6 $9 $12 $15 $18 $21} + | enewnatrec '(' String ')' '(' String ')' '(' String ')' '(' Type ')' '(' Exp ')' '(' String ')' '(' Exp ')' {NewNatRec $3 $6 $9 $12 $15 $18 $21} + | evar '(' String ')' {Var $3} + | elam '(' Mult ')' '(' String ')' '(' Type ')' '(' Exp ')' {Lam $3 $6 $9 $12} + | erec '(' String ')' '(' String ')' '(' Exp ')' '(' Exp ')' {Rec $3 $6 $9 $12} + | eapp '(' Exp ')' '(' Exp ')' {App $3 $6} + | epair '(' Mult ')' '(' String ')' '(' Exp ')' '(' Exp ')' {Pair $3 $6 $9 $12} + | eletpair '(' String ')' '(' String ')' '(' Exp ')' '(' Exp ')' {LetPair $3 $6 $9 $12} + | efst '(' Exp ')' {Fst $3} + | esnd '(' Exp ')' {Snd $3} + | efork '(' Exp ')' {Fork $3} + | enew '(' Type ')' {New $3} + | esend '(' Exp ')' {Send $3} + | erecv '(' Exp ')' {Recv $3} + | ecase '(' Exp ')' '(' SStringExpArray ')' {Case $3 $6} + | ecast '(' Exp ')' '(' Type ')' '(' Type ')' {Cast $3 $6 $9} + + +MathOp : madd '(' Exp ')' '(' Exp ')' {Add $3 $6} + | msub '(' Exp ')' '(' Exp ')' {Sub $3 $6} + | mmul '(' Exp ')' '(' Exp ')' {Mul $3 $6} + | mdiv '(' Exp ')' '(' Exp ')' {Div $3 $6} + | mneg '(' Exp ')' {Neg $3 } + +GType : gunit {GUnit} + | glabel '(' LabelType ')' {GLabel (Set.fromList $3) } + | gfunc '(' Mult ')' {GFunc $3} + | gpair {GPair} + | gnat {GNat} + | gnatleq '(' integer ')' {GNatLeq $3} + | gint {GInt} + | gdouble {GDouble} + | gstring {GString} + +PEnvEntry : penventry '(' String ')' '(' Values ')' {($3, $6)} + +PEnv : penv '[' PEnvElements ']' { $3 } + +PEnvElements : PEnvEntry ',' PEnvElements {$1 : $3} + | PEnvEntry {[$1]} + | {- empty -} {[]} + +SStringArray : sstringarray '[' SStringElements ']' {$3} + +SStringElements : String ',' SStringElements {$1 : $3} + | String {[$1]} + | {- empty -} {[]} + +SStringTypeArray : sstringtypearray '[' SStringTypeElements ']' {$3} + +SStringTypeElements : SStringTypeElement ',' SStringTypeElements {$1 : $3} + | SStringTypeElement {[$1]} + | {- empty -} {[]} + +SStringTypeElement : '(' '(' String ')' '(' Type ')' ')' {($3, $6)} + +SStringExpArray : sstringexparray '[' SStringExpElements ']' {$3} + +SStringExpElements : SStringExpElement ',' SStringExpElements {$1 : $3} + | SStringExpElement {[$1]} + | {- empty -} {[]} + +SStringExpElement : '(' '(' String ')' '(' Exp ')' ')' {($3, $6)} + +LabelType : slabeltype '{' SStringElements '}' {$3} + + { diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index 34e202b..33ae6cb 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -30,42 +30,211 @@ $upper = [A-Z] tokens :- $white+ ; - VUnit { tok $ const VUnitN } - VLabel { tok $ const VLabelN} - VInt { tok $ const VIntN} - VString { tok $ const VStringN} - VPair { tok $ const VPairN} - VSend { tok $ const VSendN} - $digit+ "." $digit+ { tok $ Double . read } - $digit+ { tok $ Int . read } - \"\"[^\"]*\"\" { tok $ String } - "<" { tok $ const LesserN } - ">" { tok $ const GreaterN } - "," { tok $ const CommaN } - "(" { tok $ const ParOpenN } - ")" { tok $ const ParCloseN } - $alpha [$alpha $digit \_ \']* { tok $ Label } + "VUnit" { tok $ const VUnit } + "VLabel" { tok $ const VLabel } + "VInt" { tok $ const VInt } + "VDouble" { tok $ const VDouble } + "VString" { tok $ const VString } + "VChan" { tok $ const VChan } + "VSend" { tok $ const VSend } + "VPair" { tok $ const VPair } + "VType" { tok $ const VType } + "VFunc" { tok $ const VFunc } + "VDynCast" { tok $ const VDynCast } + "VFuncCast" { tok $ const VFuncCast } + "VRec" { tok $ const VRec} + "VNewNatRec" { tok $ const VNewNatRec } + "TUnit" { tok $ const TUnit } + "TInt" { tok $ const TInt } + "TDouble" { tok $ const TDouble } + "TBot" { tok $ const TBot } + "TDyn" { tok $ const TDyn } + "TNat" { tok $ const TNat } + "TString" { tok $ const TString } + "TNatLeq" { tok $ const TNatLeq } + "TNatRec" { tok $ const TNatRec } + "TVar" { tok $ const TVar } + "TAbs" { tok $ const TAbs } + "TName" { tok $ const TName } + "TLab" { tok $ const TLab } + "TFun" { tok $ const TFun } + "TPair" { tok $ const TPair } + "TSend" { tok $ const TSend } + "TRecv" { tok $ const TRecv } + "TCase" { tok $ const TCase } + "TEqn" { tok $ const TEqn } + "TSingle" { tok $ const TSingle } + + "ELet" { tok $ const ELet } + "EMath" { tok $ const EMath } + "ELit" { tok $ const ELit } + "ESucc" { tok $ const ESucc } + "ENatRec" { tok $ const ENatRec } + "ENewNatRec" { tok $ const ENewNatRec } + "EVar" { tok $ const EVar } + "ELam" { tok $ const ELam } + "ERec" { tok $ const ERec } + "EApp" { tok $ const EApp } + "EPair" { tok $ const EPair } + "ELetPair" { tok $ const ELetPair } + "EFst" { tok $ const EFst } + "ESnd" { tok $ const ESnd } + "EFork" { tok $ const EFork } + "ENew" { tok $ const ENew } + "ESend" { tok $ const ESend } + "ERecv" { tok $ const ERecv } + "ECase" { tok $ const ECase } + "ECast" { tok $ const ECast } + + "MAdd" { tok $ const MAdd } + "MSub" { tok $ const MSub } + "MMul" { tok $ const MMul } + "MDiv" { tok $ const MDiv } + "MNeg" { tok $ const MNeg } + + "MOne" { tok $ const ValueParsing.ValueTokens.MOne } + "MMany" { tok $ const ValueParsing.ValueTokens.MMany } + + "LInt" { tok $ const LInt } + "LNat" { tok $ const LNat } + "LDouble" { tok $ const LDouble } + "LLab" { tok $ const LLab } + "LUnit" { tok $ const LUnit } + "LString" { tok $ const LString } + + "SFuncType" { tok $ const SFuncType } + + "GUnit" { tok $ const GUnit } + "GLabel" { tok $ const GLabel } + "GFunc" { tok $ const GFunc } + "GPair" { tok $ const GPair } + "GNat" { tok $ const GNat } + "GNatLeq" { tok $ const GNatLeq } + "GInt" { tok $ const GInt } + "GDouble" { tok $ const GDouble } + "GString" { tok $ const GString } + + "PEnv" { tok $ const PEnv } + "PEnvEntry" { tok $ const PEnvEntry } + "SLabelType" { tok $ const SLabelType } + "SStringExpArray" { tok $ const SStringExpArray } + "SStringTypeArray" { tok $ const SStringTypeArray } + "SStringArray" { tok $ const SStringArray } + + "Double:" $digit+ "." $digit+ { tok $ Double . read . (drop 7) } + "Int:" $digit+ { tok $ Int . read . (drop 4)} + "Integer:" $digit+ { tok $ Integer . read . (drop 8)} + String\:\"[^\"]*\" { tok $ String . (drop 7)} + "Bool:False" { tok $ Bool . ignoreArgument False} + "Bool:True" { tok $ Bool . ignoreArgument True} + -- TODO: Add proper String parsing: https://www.jyotirmoy.net/posts/2015-08-17-alex-happy-startcodes.html + [\=\+\-\*\/\(\)\:\!\?\{\}\[\]\<\>\,] { tok $ Sym . head } { -- The token type: -- | (Unit, Label, Int, Values of self-declared Data Types), Channels data Token - = VUnitN - | VLabelN - | VIntN - | VDoubleN - | VStringN - | VSendN - | VPairN - | Label String + = VUnit + | VLabel + | VInt + | VDouble + | VString + | VChan + | VSend + | VPair + | VType + | VFunc + | VDynCast + | VFuncCast + | VRec + | VNewNatRec + + | TUnit + | TInt + | TDouble + | TBot + | TDyn + | TNat + | TString + | TNatLeq + | TNatRec + | TVar + | TAbs + | TName + | TLab + | TFun + | TPair + | TSend + | TRecv + | TCase + | TEqn + | TSingle + + | ELet + | EMath + | ELit + | ESucc + | ENatRec + | ENewNatRec + | EVar + | ELam + | ERec + | EApp + | EPair + | ELetPair + | EFst + | ESnd + | EFork + | ENew + | ESend + | ERecv + | ECase + | ECast + + | MAdd + | MSub + | MMul + | MDiv + | MNeg + + | MOne + | MMany + + | LInt + | LNat + | LDouble + | LLab + | LUnit + | LString + + | SFuncType + + | GUnit + | GLabel + | GFunc + | GPair + | GNat + | GNatLeq + | GInt + | GDouble + | GString + + | PEnv + | PEnvEntry + + | SLabelType + + | SStringExpArray + | SStringTypeArray + | SStringArray + | String String | Int Int + | Integer Integer | Double Double - | GreaterN - | LesserN - | CommaN - | ParOpenN - | ParCloseN + | Bool Bool + + | Sym Char | EOF deriving (Eq, Show) @@ -123,6 +292,9 @@ scanner str = runAlex str $ do then return i else do loop $! (i++[(tokVal tok)]) loop [] + + +ignoreArgument a b = a } -- https://gist.github.com/m1dnight/126d6b500175c2c286e3804584e5c4ce \ No newline at end of file From a60a9ffd0130e096f20f56b673a22f7bdccca09a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 21 Nov 2022 18:12:16 +0100 Subject: [PATCH 007/229] updated parsing --- src/ProcessEnvironment.hs | 1 + src/SerializeValues.hs | 5 ++++- src/ValueParsing/ValueGrammar.y | 9 ++++++++- src/ValueParsing/ValueTokens.x | 2 ++ 4 files changed, 15 insertions(+), 2 deletions(-) diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index c023848..c87913e 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -43,6 +43,7 @@ data Value -- we have two channels, one for reading and one for writing to the other -- end, so we do not read our own written values | VChan (C.Chan ValueRepr) (C.Chan ValueRepr) +-- | VChan (C.Chan Value) (C.Chan Value) | VSend Value | VPair Value Value -- pair of ids that map to two values | VType S.Type diff --git a/src/SerializeValues.hs b/src/SerializeValues.hs index 3f6f677..74a828b 100644 --- a/src/SerializeValues.hs +++ b/src/SerializeValues.hs @@ -19,7 +19,7 @@ instance Serializable Value where VInt i -> "VInt (" ++ serialize i ++ ")" VDouble d -> "VDouble (" ++ serialize d ++ ")" VString s -> "VString (" ++ serialize s ++ ")" - VChan _ _ -> "VChan" +-- VChan c1 c2 -> "VChan (" ++ serialize c1 ++ ") (" ++ serialize c2 ++ ")" VSend v -> "VSend (" ++ serialize v ++ ")" VPair a b -> "VPair (" ++ serialize a ++ ") (" ++ serialize b ++ ")" VType t -> "VType (" ++ serialize t ++ ")" @@ -157,6 +157,9 @@ instance {-# OVERLAPPING #-} Serializable [(String, Type)] where instance {-# OVERLAPPING #-} Serializable [String] where serialize arr = "SStringArray [" ++ serializeElements arr ++ "]" +instance {-# OVERLAPPING #-}Serializable [Value] where + serialize arr = "SValuesArray [" ++ serializeElements arr ++ "]" + serializeElements :: Serializable a => [a] -> String serializeElements [] = "" serializeElements [x] = serialize x diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 3c09859..f948c59 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -104,6 +104,7 @@ import qualified ValueParsing.ValueTokens as T sstringexparray { T _ T.SStringExpArray } sstringtypearray { T _ T.SStringTypeArray } sstringarray { T _ T.SStringArray } + svaluesarray { T _ T.SValuesArray } gunit { T _ T.GUnit } glabel { T _ T.GLabel } @@ -162,7 +163,7 @@ Values : vunit { VUnit } | vint '(' int ')' {VInt $3} | vdouble '(' double ')' {VDouble $3} | vstring '(' String ')' {VString $3 } --- | vchan {VChan "" "" } +-- | vchan '(' SValuesArray ')' '(' SValuesArray ')' {VChan $3 $6} | vsend '(' Values ')' {VSend $3} | vpair '(' Values ')' '(' Values ')' {VPair $3 $6} | vtype '(' Type ')' {VType $3} @@ -276,6 +277,12 @@ SStringExpElements : SStringExpElement ',' SStringExpElements {$1 : $3} SStringExpElement : '(' '(' String ')' '(' Exp ')' ')' {($3, $6)} +SValuesArray : svaluesarray '[' SValuesElements ']' {$3} + +SValuesElements : Values ',' SValuesElements {$1 : $3} + | Values {[$1]} + | {- empty -} {[]} + LabelType : slabeltype '{' SStringElements '}' {$3} diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index 33ae6cb..599ac4f 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -121,6 +121,7 @@ tokens :- "SStringExpArray" { tok $ const SStringExpArray } "SStringTypeArray" { tok $ const SStringTypeArray } "SStringArray" { tok $ const SStringArray } + "SValuesArray" { tok $ const SValuesArray } "Double:" $digit+ "." $digit+ { tok $ Double . read . (drop 7) } "Int:" $digit+ { tok $ Int . read . (drop 4)} @@ -227,6 +228,7 @@ data Token | SStringExpArray | SStringTypeArray | SStringArray + | SValuesArray | String String | Int Int From bee0f77a5bdd815d14b8ba7db2127dd79cd4b82a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 22 Nov 2022 15:55:04 +0100 Subject: [PATCH 008/229] first implementation of new commands --- dev-examples/client.ldgvnw | 19 +++++++++++++++++++ dev-examples/server.ldgvnw | 19 +++++++++++++++++++ ldgv.cabal | 2 ++ newsyntax.txt | 2 ++ src/Networking/Client.hs | 1 + src/Networking/Server.hs | 1 + src/Parsing/Grammar.y | 8 ++++++-- src/Parsing/Tokens.x | 4 ++++ src/PrettySyntax.hs | 2 ++ src/Syntax.hs | 3 +++ 10 files changed, 59 insertions(+), 2 deletions(-) create mode 100644 dev-examples/client.ldgvnw create mode 100644 dev-examples/server.ldgvnw create mode 100644 newsyntax.txt create mode 100644 src/Networking/Client.hs create mode 100644 src/Networking/Server.hs diff --git a/dev-examples/client.ldgvnw b/dev-examples/client.ldgvnw new file mode 100644 index 0000000..b0d030d --- /dev/null +++ b/dev-examples/client.ldgvnw @@ -0,0 +1,19 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let y = ((send x) 42) in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val main : Unit +val main = + let con = (connect "localhost" 4242 SendInt) in + send2 con diff --git a/dev-examples/server.ldgvnw b/dev-examples/server.ldgvnw new file mode 100644 index 0000000..b76baaa --- /dev/null +++ b/dev-examples/server.ldgvnw @@ -0,0 +1,19 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let y = ((send x) 42) in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val main : Int +val main = + let con = (create 4242 (dualof SendInt)) in + add2 con diff --git a/ldgv.cabal b/ldgv.cabal index 7ac97cb..8c3615b 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -65,6 +65,8 @@ library Examples Interpreter Kinds + Networking.Client + Networking.Server Parsing Parsing.Grammar Parsing.Tokens diff --git a/newsyntax.txt b/newsyntax.txt new file mode 100644 index 0000000..2568e88 --- /dev/null +++ b/newsyntax.txt @@ -0,0 +1,2 @@ +create -- Creates a server socket +connect -- Connects to a server \ No newline at end of file diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs new file mode 100644 index 0000000..b90d829 --- /dev/null +++ b/src/Networking/Client.hs @@ -0,0 +1 @@ +module Networking.Client where \ No newline at end of file diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs new file mode 100644 index 0000000..fb0e7cc --- /dev/null +++ b/src/Networking/Server.hs @@ -0,0 +1 @@ +module Networking.Server where \ No newline at end of file diff --git a/src/Parsing/Grammar.y b/src/Parsing/Grammar.y index d339843..89d2a4b 100644 --- a/src/Parsing/Grammar.y +++ b/src/Parsing/Grammar.y @@ -36,6 +36,8 @@ import qualified Parsing.Tokens as T new { T _ T.New } send { T _ T.Send } recv { T _ T.Recv } + create { T _ T.Create } + connect { T _ T.Connect } -- for Binary Session Types; obsolete for Label Dependent ones select { T _ T.Select } @@ -91,7 +93,7 @@ import qualified Parsing.Tokens as T %nonassoc '>' '<' %left '+' '-' NEG POS %left '*' '/' -%left send recv +%left send recv connect create %nonassoc APP @@ -166,7 +168,9 @@ Exp : let var '=' Exp in Exp %prec LET { Let $2 $4 $6 } | fork Exp { Fork $2 } | send Exp %prec send { Send $2 } | recv Exp %prec recv { Recv $2 } - | Exp Exp %prec APP { App $1 $2 } + | create Exp Typ %prec create { Create $2 $3 } + | connect Exp Exp Typ %prec connect { Connect $2 $3 $4 } + | Exp Exp %prec APP { App $1 $2 } Labs : lab { [$1] } | lab ',' Labs { $1 : $3 } diff --git a/src/Parsing/Tokens.x b/src/Parsing/Tokens.x index c80c098..bb63032 100644 --- a/src/Parsing/Tokens.x +++ b/src/Parsing/Tokens.x @@ -42,6 +42,8 @@ tokens :- new { tok $ const New } send { tok $ const Send } recv { tok $ const Recv } + create { tok $ const Create } + connect { tok $ const Connect } -- for Binary Session Types; obsolete for Label Dependent ones select { tok $ const Select } @@ -96,6 +98,8 @@ data Token = New | Send | Recv | + Create | + Connect | -- for Binary Session Types; obsolete for Label Dependent ones Select | diff --git a/src/PrettySyntax.hs b/src/PrettySyntax.hs index 5f2be89..02bb934 100644 --- a/src/PrettySyntax.hs +++ b/src/PrettySyntax.hs @@ -123,6 +123,8 @@ instance Pretty Exp where pretty (New t) = pretty "new" <+> pretty t pretty (Send e) = pretty "send" <+> pretty e pretty (Recv e) = pretty "recv" <+> pretty e + pretty (Create i t) = pretty "create" <+> pretty i + pretty (Connect a i t) = pretty "create" <+> pretty a <+> pretty i <+> pretty t pretty (Case e ses) = pcase e ses pretty (Cast e t1 t2) = diff --git a/src/Syntax.hs b/src/Syntax.hs index 77c0972..ca0f843 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -32,6 +32,9 @@ data Exp = Let Ident Exp Exp | Recv Exp | Case Exp [(String, Exp)] | Cast Exp Type Type + -- New types + | Create Exp Type -- Create Port Type + | Connect Exp Exp Type -- Connect URL Port Type deriving (Show,Eq) data MathOp e From 5d86ce9f480d0c67069b60cb7c5f90ec1aaae827 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 23 Nov 2022 14:59:00 +0100 Subject: [PATCH 009/229] Early networking implementation, likely not working --- ldgv.cabal | 2 ++ package.yaml | 2 ++ src/Interpreter.hs | 29 ++++++++++++++++++++--------- src/Networking/Server.hs | 37 ++++++++++++++++++++++++++++++++++++- src/ProcessEnvironment.hs | 2 +- src/Syntax.hs | 4 ++++ src/TCTyping.hs | 7 +++++++ 7 files changed, 72 insertions(+), 11 deletions(-) diff --git a/ldgv.cabal b/ldgv.cabal index 8c3615b..1015cfb 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -99,6 +99,8 @@ library , filepath , lens , mtl + , network + , network-run , prettyprinter , text , transformers diff --git a/package.yaml b/package.yaml index 32ba7d4..231b484 100644 --- a/package.yaml +++ b/package.yaml @@ -60,6 +60,8 @@ library: - transformers - typed-process - validation-selective + - network + - network-run tests: ldgv-test: diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 42b60ee..1ab0c3c 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -25,6 +25,10 @@ import qualified SerializeValues as SV import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG +import qualified Networking.Server as NS + +import Network.Run.TCP +import qualified Networking.Server as NS data InterpreterException = MathException String @@ -144,14 +148,22 @@ eval = \case Send e -> VSend <$> interpret' e -- Apply VSend to the output of interpret' e Recv e -> do interpret' e >>= \v@(VChan c _) -> do - chanString <- liftIO $ Chan.readChan c - case VT.runAlex chanString VG.parseValues of - -- Translate Value Strings back into Values - Left err -> throw $ DeserializationException err - Right val -> do - liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e - return $ VPair val v + val <- liftIO $ Chan.readChan c + liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e + return $ VPair val v Case e cases -> interpret' e >>= \(VLabel s) -> interpret' $ fromJust $ lookup s cases + Create e t -> do + interpret' e >>= \(VInt port) -> do + r <- liftIO Chan.newChan + w <- liftIO Chan.newChan + liftIO $ runTCPServer Nothing (show port) (NS.communicate r w) + return $ VChan r w + Connect e1 e2 t -> do + interpret' e1 >>= \(VString address) -> interpret' e2 >>= \(VInt port) -> do + r <- liftIO Chan.newChan + w <- liftIO Chan.newChan + liftIO $ runTCPClient address (show port) (NS.communicate r w) + return $ VChan r w e -> throw $ NotImplementedException e -- Exp is only used for blame @@ -185,8 +197,7 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) | n > 0 = do let env' = extendEnv n1 (VInt (n-1)) (extendEnv f natrec env) R.local (const env') (interpret' es) -interpretApp _ (VSend v@(VChan _ c)) w = liftIO (Chan.writeChan c (SV.serialize w)) >> return v --- Convert the Values to Strings +interpretApp _ (VSend v@(VChan _ c)) w = liftIO (Chan.writeChan c w) >> return v interpretApp e _ _ = throw $ ApplicationException e interpretLit :: Literal -> Value diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index fb0e7cc..f7ecdc9 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -1 +1,36 @@ -module Networking.Server where \ No newline at end of file +module Networking.Server where + +import qualified Control.Exception as E +import qualified Data.ByteString.Char8 as C +import Network.Socket +import Network.Socket.ByteString (recv, sendAll) +import Control.Concurrent +import GHC.IO.Handle +import System.IO +import qualified Control.Concurrent.Chan as Chan +import ProcessEnvironment + + +import qualified ValueParsing.ValueTokens as VT +import qualified ValueParsing.ValueGrammar as VG +import qualified SerializeValues as SV + +-- communicate :: Chan.Chan Value -> Chan.Chan Value -> Socket -> IO () +communicate read write socket = do + hdl <- socketToHandle socket ReadWriteMode + hSetBuffering hdl NoBuffering + forkIO (sendWritten write hdl) + recieveReadable read hdl + where + sendWritten write handle = do + message <- readChan write + hPutStrLn handle (SV.serialize message ++" ") + sendWritten write handle + + recieveReadable read handle = do + message <- hGetLine handle + case VT.runAlex message VG.parseValues of + Left err -> putStrLn $ "Error during recieving a networkmessage: "++err + Right deserial -> writeChan read deserial + recieveReadable read handle + diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index c87913e..d58964a 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -42,7 +42,7 @@ data Value | VString String -- we have two channels, one for reading and one for writing to the other -- end, so we do not read our own written values - | VChan (C.Chan ValueRepr) (C.Chan ValueRepr) + | VChan (C.Chan Value) (C.Chan Value) -- | VChan (C.Chan Value) (C.Chan Value) | VSend Value | VPair Value Value -- pair of ids that map to two values diff --git a/src/Syntax.hs b/src/Syntax.hs index ca0f843..a7a1a89 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -168,6 +168,8 @@ instance Freevars Exp where fv (New ty) = fv ty fv (Send e1) = fv e1 fv (Recv e1) = fv e1 + fv (Create e1 ty) = fv e1 <> fv ty + fv (Connect e1 e2 ty) = fv e1 <> fv e2 <> fv ty fv (Case e cases) = foldl' (<>) (fv e) $ map (fv . snd) cases fv (Cast e t1 t2) = fv e fv (Succ e) = fv e @@ -234,6 +236,8 @@ instance Substitution Exp where sb (New t) = New t sb (Send e1) = Send (sb e1) sb (Recv e1) = Recv (sb e1) + sb (Create e1 t) = Create (sb e1) t + sb (Connect e1 e2 t) = Connect (sb e1) (sb e2) t sb (Succ e1) = Succ (sb e1) sb (NatRec e ez y t z tyz es) = NatRec (sb e) (sb ez) y t z (subst x exp tyz) (if x /= y && x /= z then sb es else es) diff --git a/src/TCTyping.hs b/src/TCTyping.hs index 52d7b1f..c38042f 100644 --- a/src/TCTyping.hs +++ b/src/TCTyping.hs @@ -241,6 +241,13 @@ tySynth te e = New ty -> do kiCheck (demoteTE te) ty Kssn return (TPair "" ty (dualof ty), te) + -- I've got no real clue of what I am doing here hope it kind of works + Create e1 ty -> do + kiCheck (demoteTE te) ty Kssn + return (ty, te) + Connect e1 e2 ty -> do + kiCheck (demoteTE te) ty Kssn + return (ty, te) Send e1 -> do (ts, te1) <- tySynth te e1 tsu <- unfold te1 ts From f15b1c6c53710121fd827d4fedc17436690f4a5d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 23 Nov 2022 16:10:50 +0100 Subject: [PATCH 010/229] The recieving portion works now The send command still needs to be emulated with telnet --- src/Interpreter.hs | 26 ++++++++++++++++---------- src/Networking/Server.hs | 2 ++ src/PrettySyntax.hs | 2 +- 3 files changed, 19 insertions(+), 11 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 1ab0c3c..4091b6c 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -153,17 +153,23 @@ eval = \case return $ VPair val v Case e cases -> interpret' e >>= \(VLabel s) -> interpret' $ fromJust $ lookup s cases Create e t -> do - interpret' e >>= \(VInt port) -> do - r <- liftIO Chan.newChan - w <- liftIO Chan.newChan - liftIO $ runTCPServer Nothing (show port) (NS.communicate r w) - return $ VChan r w + liftIO $ C.traceIO "Creating server!" + -- interpret' e >>= \(VInt port) -> do + r <- liftIO Chan.newChan + w <- liftIO Chan.newChan + -- liftIO $ runTCPServer Nothing (show port) (NS.communicate r w) + liftIO $ forkIO $ runTCPServer Nothing "4242" (NS.communicate r w) + liftIO $ C.traceIO "Server created" + return $ VChan r w Connect e1 e2 t -> do - interpret' e1 >>= \(VString address) -> interpret' e2 >>= \(VInt port) -> do - r <- liftIO Chan.newChan - w <- liftIO Chan.newChan - liftIO $ runTCPClient address (show port) (NS.communicate r w) - return $ VChan r w + -- interpret' e1 >>= \(VString address) -> interpret' e2 >>= \(VInt port) -> do + r <- liftIO Chan.newChan + w <- liftIO Chan.newChan + liftIO $ C.traceIO "Client trying to connect" + -- liftIO $ runTCPClient address (show port) (NS.communicate r w) + liftIO $ forkIO $ runTCPClient "localhost" "4242" (NS.communicate r w) + liftIO $ C.traceIO "Client connected" + return $ VChan r w e -> throw $ NotImplementedException e -- Exp is only used for blame diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index f7ecdc9..7fae4be 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -24,11 +24,13 @@ communicate read write socket = do where sendWritten write handle = do message <- readChan write + putStrLn $ "Sending message:" ++ SV.serialize message hPutStrLn handle (SV.serialize message ++" ") sendWritten write handle recieveReadable read handle = do message <- hGetLine handle + putStrLn $ "Recieved message:" ++ message case VT.runAlex message VG.parseValues of Left err -> putStrLn $ "Error during recieving a networkmessage: "++err Right deserial -> writeChan read deserial diff --git a/src/PrettySyntax.hs b/src/PrettySyntax.hs index 02bb934..8be5364 100644 --- a/src/PrettySyntax.hs +++ b/src/PrettySyntax.hs @@ -124,7 +124,7 @@ instance Pretty Exp where pretty (Send e) = pretty "send" <+> pretty e pretty (Recv e) = pretty "recv" <+> pretty e pretty (Create i t) = pretty "create" <+> pretty i - pretty (Connect a i t) = pretty "create" <+> pretty a <+> pretty i <+> pretty t + pretty (Connect a i t) = pretty "connect" <+> pretty a <+> pretty i <+> pretty t pretty (Case e ses) = pcase e ses pretty (Cast e t1 t2) = From 15b0e0dbbcabdcb2d720c8881bd04bf06aa6fecd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 23 Nov 2022 16:52:45 +0100 Subject: [PATCH 011/229] Sending works more or less now --- src/Interpreter.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 4091b6c..bfe3f34 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -30,6 +30,8 @@ import qualified Networking.Server as NS import Network.Run.TCP import qualified Networking.Server as NS +import Control.Concurrent + data InterpreterException = MathException String | LookupException String @@ -167,7 +169,7 @@ eval = \case w <- liftIO Chan.newChan liftIO $ C.traceIO "Client trying to connect" -- liftIO $ runTCPClient address (show port) (NS.communicate r w) - liftIO $ forkIO $ runTCPClient "localhost" "4242" (NS.communicate r w) + liftIO $ forkIO $ runTCPClient "127.0.0.1" "4242" (NS.communicate r w) liftIO $ C.traceIO "Client connected" return $ VChan r w e -> throw $ NotImplementedException e @@ -203,7 +205,10 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) | n > 0 = do let env' = extendEnv n1 (VInt (n-1)) (extendEnv f natrec env) R.local (const env') (interpret' es) -interpretApp _ (VSend v@(VChan _ c)) w = liftIO (Chan.writeChan c w) >> return v +interpretApp _ (VSend v@(VChan _ c)) w = do + liftIO (Chan.writeChan c w) + liftIO $ threadDelay 1000000 -- give send thread time to send + return v interpretApp e _ _ = throw $ ApplicationException e interpretLit :: Literal -> Value From 43484ccf80f26c579b1be0be4f5a9793b36f8fd5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 23 Nov 2022 17:36:39 +0100 Subject: [PATCH 012/229] Update client.ldgvnw --- dev-examples/client.ldgvnw | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dev-examples/client.ldgvnw b/dev-examples/client.ldgvnw index b0d030d..7996182 100644 --- a/dev-examples/client.ldgvnw +++ b/dev-examples/client.ldgvnw @@ -15,5 +15,5 @@ val add2 (c1: dualof SendInt) = val main : Unit val main = - let con = (connect "localhost" 4242 SendInt) in + let con = (connect "127.0.0.1" 4242 SendInt) in -- This cannot be localhost, since this might break on containerized images send2 con From b45e381828472a3c88a2e54d62c9a0b028898ce9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 23 Nov 2022 18:05:01 +0100 Subject: [PATCH 013/229] Added option for variables --- src/Interpreter.hs | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index bfe3f34..8815e22 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -42,6 +42,7 @@ data InterpreterException | NotImplementedException Exp | TypeNotImplementedException Type | DeserializationException String + | NotAnExpectedValueException String Value deriving Eq instance Show InterpreterException where @@ -55,6 +56,7 @@ instance Show InterpreterException where (NotImplementedException exp) -> "NotImplementedException: " ++ pshow exp (TypeNotImplementedException typ) -> "TypeNotImplementedException: " ++ pshow typ (DeserializationException err) -> "DeserializationException: " ++ err + (NotAnExpectedValueException expected val) -> "NotAnExpectedValueException: This expresion: (" ++ pshow val ++ ") is not of type: " ++ expected instance Exception InterpreterException @@ -156,21 +158,31 @@ eval = \case Case e cases -> interpret' e >>= \(VLabel s) -> interpret' $ fromJust $ lookup s cases Create e t -> do liftIO $ C.traceIO "Creating server!" - -- interpret' e >>= \(VInt port) -> do r <- liftIO Chan.newChan w <- liftIO Chan.newChan - -- liftIO $ runTCPServer Nothing (show port) (NS.communicate r w) - liftIO $ forkIO $ runTCPServer Nothing "4242" (NS.communicate r w) - liftIO $ C.traceIO "Server created" + + val <- interpret' e + case val of + VInt port -> do + liftIO $ forkIO $ runTCPServer Nothing (show port) (NS.communicate r w) + liftIO $ C.traceIO "Server created" + _ -> throw $ NotAnExpectedValueException "VInt" val return $ VChan r w Connect e1 e2 t -> do - -- interpret' e1 >>= \(VString address) -> interpret' e2 >>= \(VInt port) -> do r <- liftIO Chan.newChan w <- liftIO Chan.newChan liftIO $ C.traceIO "Client trying to connect" - -- liftIO $ runTCPClient address (show port) (NS.communicate r w) - liftIO $ forkIO $ runTCPClient "127.0.0.1" "4242" (NS.communicate r w) - liftIO $ C.traceIO "Client connected" + + addressVal <- interpret' e1 + case addressVal of + VString address -> do + portVal <- interpret' e2 + case portVal of + VInt port -> do + liftIO $ forkIO $ runTCPClient address (show port) (NS.communicate r w) + liftIO $ C.traceIO "Client connected" + _ -> throw $ NotAnExpectedValueException "VInt" portVal + _ -> throw $ NotAnExpectedValueException "VString" addressVal return $ VChan r w e -> throw $ NotImplementedException e From 6e8ddeee03c755a745ada7b96cc245a06a6ab9a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 23 Nov 2022 18:19:51 +0100 Subject: [PATCH 014/229] Update Interpreter.hs --- src/Interpreter.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 8815e22..0a15f41 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -172,7 +172,7 @@ eval = \case r <- liftIO Chan.newChan w <- liftIO Chan.newChan liftIO $ C.traceIO "Client trying to connect" - + addressVal <- interpret' e1 case addressVal of VString address -> do @@ -219,7 +219,8 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) R.local (const env') (interpret' es) interpretApp _ (VSend v@(VChan _ c)) w = do liftIO (Chan.writeChan c w) - liftIO $ threadDelay 1000000 -- give send thread time to send + liftIO $ threadDelay 100000 -- give send thread time to send + -- I obviously need to remove this ugly hack return v interpretApp e _ _ = throw $ ApplicationException e From 73f55c58c5e24fed865ef0324abc007bb91ca3fa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 23 Nov 2022 18:31:27 +0100 Subject: [PATCH 015/229] Moved Common networking code --- ldgv.cabal | 1 + src/Interpreter.hs | 6 +++--- src/Networking/Common.hs | 38 ++++++++++++++++++++++++++++++++++++++ src/Networking/Server.hs | 39 +-------------------------------------- 4 files changed, 43 insertions(+), 41 deletions(-) create mode 100644 src/Networking/Common.hs diff --git a/ldgv.cabal b/ldgv.cabal index 1015cfb..ea8172f 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -66,6 +66,7 @@ library Interpreter Kinds Networking.Client + Networking.Common Networking.Server Parsing Parsing.Grammar diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 0a15f41..bd858a3 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -25,7 +25,7 @@ import qualified SerializeValues as SV import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG -import qualified Networking.Server as NS +import qualified Networking.Common as NC import Network.Run.TCP import qualified Networking.Server as NS @@ -164,7 +164,7 @@ eval = \case val <- interpret' e case val of VInt port -> do - liftIO $ forkIO $ runTCPServer Nothing (show port) (NS.communicate r w) + liftIO $ forkIO $ runTCPServer Nothing (show port) (NC.communicate r w) liftIO $ C.traceIO "Server created" _ -> throw $ NotAnExpectedValueException "VInt" val return $ VChan r w @@ -179,7 +179,7 @@ eval = \case portVal <- interpret' e2 case portVal of VInt port -> do - liftIO $ forkIO $ runTCPClient address (show port) (NS.communicate r w) + liftIO $ forkIO $ runTCPClient address (show port) (NC.communicate r w) liftIO $ C.traceIO "Client connected" _ -> throw $ NotAnExpectedValueException "VInt" portVal _ -> throw $ NotAnExpectedValueException "VString" addressVal diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs new file mode 100644 index 0000000..8ecf939 --- /dev/null +++ b/src/Networking/Common.hs @@ -0,0 +1,38 @@ +module Networking.Common where + +import qualified Control.Exception as E +import qualified Data.ByteString.Char8 as C +import Network.Socket +import Network.Socket.ByteString (recv, sendAll) +import Control.Concurrent +import GHC.IO.Handle +import System.IO +import qualified Control.Concurrent.Chan as Chan +import ProcessEnvironment + + +import qualified ValueParsing.ValueTokens as VT +import qualified ValueParsing.ValueGrammar as VG +import qualified SerializeValues as SV + +-- communicate :: Chan.Chan Value -> Chan.Chan Value -> Socket -> IO () +communicate read write socket = do + hdl <- socketToHandle socket ReadWriteMode + hSetBuffering hdl NoBuffering + forkIO (sendWritten write hdl) + recieveReadable read hdl + where + sendWritten write handle = do + message <- readChan write + putStrLn $ "Sending message:" ++ SV.serialize message + hPutStrLn handle (SV.serialize message ++" ") + sendWritten write handle + + recieveReadable read handle = do + message <- hGetLine handle + putStrLn $ "Recieved message:" ++ message + case VT.runAlex message VG.parseValues of + Left err -> putStrLn $ "Error during recieving a networkmessage: "++err + Right deserial -> writeChan read deserial + recieveReadable read handle + diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 7fae4be..fb0e7cc 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -1,38 +1 @@ -module Networking.Server where - -import qualified Control.Exception as E -import qualified Data.ByteString.Char8 as C -import Network.Socket -import Network.Socket.ByteString (recv, sendAll) -import Control.Concurrent -import GHC.IO.Handle -import System.IO -import qualified Control.Concurrent.Chan as Chan -import ProcessEnvironment - - -import qualified ValueParsing.ValueTokens as VT -import qualified ValueParsing.ValueGrammar as VG -import qualified SerializeValues as SV - --- communicate :: Chan.Chan Value -> Chan.Chan Value -> Socket -> IO () -communicate read write socket = do - hdl <- socketToHandle socket ReadWriteMode - hSetBuffering hdl NoBuffering - forkIO (sendWritten write hdl) - recieveReadable read hdl - where - sendWritten write handle = do - message <- readChan write - putStrLn $ "Sending message:" ++ SV.serialize message - hPutStrLn handle (SV.serialize message ++" ") - sendWritten write handle - - recieveReadable read handle = do - message <- hGetLine handle - putStrLn $ "Recieved message:" ++ message - case VT.runAlex message VG.parseValues of - Left err -> putStrLn $ "Error during recieving a networkmessage: "++err - Right deserial -> writeChan read deserial - recieveReadable read handle - +module Networking.Server where \ No newline at end of file From fa8961e912fb62e18e0d5a4e1eb7c8af8d76d445 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 28 Nov 2022 17:02:42 +0100 Subject: [PATCH 016/229] additional patch --- dev-examples/server copy.ldgvnw | 19 +++++++++++ dev-examples/server.ldgvnw | 5 +-- ldgv.cabal | 3 ++ src/Interpreter.hs | 24 ++++++++++--- src/Networking/Common.hs | 7 ++++ src/Networking/DirectionalConnection.hs | 45 +++++++++++++++++++++++++ src/Networking/Messages.hs | 13 +++++++ src/Networking/NetworkConnection.hs | 18 ++++++++++ src/Parsing/Grammar.y | 8 +++-- src/Parsing/Tokens.x | 2 ++ src/PrettySyntax.hs | 5 ++- src/ProcessEnvironment.hs | 5 +++ src/Syntax.hs | 10 ++++-- src/TCTyping.hs | 7 ++-- 14 files changed, 156 insertions(+), 15 deletions(-) create mode 100644 dev-examples/server copy.ldgvnw create mode 100644 src/Networking/DirectionalConnection.hs create mode 100644 src/Networking/Messages.hs create mode 100644 src/Networking/NetworkConnection.hs diff --git a/dev-examples/server copy.ldgvnw b/dev-examples/server copy.ldgvnw new file mode 100644 index 0000000..b76baaa --- /dev/null +++ b/dev-examples/server copy.ldgvnw @@ -0,0 +1,19 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let y = ((send x) 42) in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val main : Int +val main = + let con = (create 4242 (dualof SendInt)) in + add2 con diff --git a/dev-examples/server.ldgvnw b/dev-examples/server.ldgvnw index b76baaa..56004ce 100644 --- a/dev-examples/server.ldgvnw +++ b/dev-examples/server.ldgvnw @@ -15,5 +15,6 @@ val add2 (c1: dualof SendInt) = val main : Int val main = - let con = (create 4242 (dualof SendInt)) in - add2 con + let con = (create 4242) in + let sock = (accept con (dualof SendInt)) in + add2 sock diff --git a/ldgv.cabal b/ldgv.cabal index ea8172f..3d25cf1 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -67,6 +67,9 @@ library Kinds Networking.Client Networking.Common + Networking.DirectionalConnection + Networking.Messages + Networking.NetworkConnection Networking.Server Parsing Parsing.Grammar diff --git a/src/Interpreter.hs b/src/Interpreter.hs index bd858a3..bd960a6 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -12,6 +12,7 @@ import qualified Config as C import Syntax import PrettySyntax import qualified Control.Concurrent.Chan as Chan +import qualified Control.Concurrent.MVar as MVar import Control.Concurrent (forkIO) import Data.Foldable (find) import Data.Maybe (fromJust) @@ -156,18 +157,33 @@ eval = \case liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e return $ VPair val v Case e cases -> interpret' e >>= \(VLabel s) -> interpret' $ fromJust $ lookup s cases - Create e t -> do + Create e -> do liftIO $ C.traceIO "Creating server!" - r <- liftIO Chan.newChan - w <- liftIO Chan.newChan val <- interpret' e case val of VInt port -> do - liftIO $ forkIO $ runTCPServer Nothing (show port) (NC.communicate r w) + mvar <- liftIO MVar.newEmptyMVar + liftIO $ forkIO $ runTCPServer Nothing (show port) (NC.getSocket mvar) liftIO $ C.traceIO "Server created" + return $ VServerSocket mvar _ -> throw $ NotAnExpectedValueException "VInt" val + + Accept e t -> do + liftIO $ C.traceIO "Accepting new client!" + r <- liftIO Chan.newChan + w <- liftIO Chan.newChan + + val <- interpret' e + case val of + VServerSocket socketMVar -> do + socket <- liftIO $ MVar.readMVar socketMVar + liftIO $ C.traceIO "Aquired socket" + liftIO $ forkIO $ NC.communicate r w socket + liftIO $ C.traceIO "Client accepted" + _ -> throw $ NotAnExpectedValueException "VServerSocket" val return $ VChan r w + Connect e1 e2 t -> do r <- liftIO Chan.newChan w <- liftIO Chan.newChan diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 8ecf939..eee4322 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -8,6 +8,7 @@ import Control.Concurrent import GHC.IO.Handle import System.IO import qualified Control.Concurrent.Chan as Chan +import qualified Control.Concurrent.MVar as MVar import ProcessEnvironment @@ -36,3 +37,9 @@ communicate read write socket = do Right deserial -> writeChan read deserial recieveReadable read handle + +getSocket :: MVar.MVar Socket -> Socket -> IO () +getSocket mvar socket = do + putStrLn "Trying to send socket" + MVar.putMVar mvar socket + putStrLn "Sent socket" diff --git a/src/Networking/DirectionalConnection.hs b/src/Networking/DirectionalConnection.hs new file mode 100644 index 0000000..478cf07 --- /dev/null +++ b/src/Networking/DirectionalConnection.hs @@ -0,0 +1,45 @@ +module Networking.DirectionalConnection (DirectionalConnection(..)) where + +import Control.Concurrent.Chan +import Control.Concurrent.MVar + +data DirectionalConnection a = DirectionalConnection { messagesAll :: Chan a, messagesUnread :: Chan a, messagesUnreadStart :: MVar Int, messagesEnd :: MVar Int} + deriving Eq + + +newConnection :: IO (DirectionalConnection a) +newConnection = do + messagesAll <- newChan + messagesUnread <- dupChan messagesAll + messagesUnreadStart <- newEmptyMVar + putMVar messagesUnreadStart 0 + messagesEnd <- newEmptyMVar + putMVar messagesEnd 0 + return $ DirectionalConnection messagesAll messagesUnread messagesUnreadStart messagesEnd + +writeMessage :: DirectionalConnection a -> a -> IO () +writeMessage connection message = do + writeChan (messagesAll connection) message -- We only need to write it to one channel, since we duplicated them + modifyMVar_ (messagesEnd connection) (\i -> return $ i+1) + +-- Gives all outMessages until this point +allMessages :: DirectionalConnection a -> IO [a] +allMessages connection = do + messagesEnd <- readMVar $ messagesEnd connection + messagesDup <- dupChan $ messagesAll connection + giveMessages messagesDup messagesEnd + where + giveMessages :: Chan a -> Int -> IO [a] + giveMessages messages 0 = return [] + giveMessages messages count = do + x <- readChan messages + xs <- giveMessages messages $ count-1 + return (x:xs) + +readUnreadMessage :: DirectionalConnection a -> IO a +readUnreadMessage connection = do + modifyMVar_ (messagesUnreadStart connection) (\i -> return $ i+1) + readChan $ messagesUnread connection + + + diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs new file mode 100644 index 0000000..fae75df --- /dev/null +++ b/src/Networking/Messages.hs @@ -0,0 +1,13 @@ +module Networking.Messages where + +import ProcessEnvironment + +type Partner = String +type Hostname = String +type Port = Int + +data Message + = NewValue Partner Value + | SyncIncomming Partner [Value] + | RequestSync Partner + | ChangePartnerAddress Partner Hostname Port diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs new file mode 100644 index 0000000..c0e26a0 --- /dev/null +++ b/src/Networking/NetworkConnection.hs @@ -0,0 +1,18 @@ +module Networking.NetworkConnection where + +{- +import Networking.DirectionalConnection +import GHC.IO.Handle +import Network.Run.TCP + + +data NetworkingConnection a = NetworkingConnection {ingoing :: DirectionalConnection a, outgoing :: DirectionalConnection a, networkHandle :: Handle} + +type Hostname = String +type Port = Int + +newConnection :: Maybe Hostname -> Port -> NetworkingConnection a +newConnection maybeHost port = do + case maybeHost of + Nothing -> runTCPServer Nothing (show port) (NC.communicate r w) + -} diff --git a/src/Parsing/Grammar.y b/src/Parsing/Grammar.y index 89d2a4b..2c65dde 100644 --- a/src/Parsing/Grammar.y +++ b/src/Parsing/Grammar.y @@ -38,6 +38,7 @@ import qualified Parsing.Tokens as T recv { T _ T.Recv } create { T _ T.Create } connect { T _ T.Connect } + accept { T _ T.Accept } -- for Binary Session Types; obsolete for Label Dependent ones select { T _ T.Select } @@ -93,7 +94,7 @@ import qualified Parsing.Tokens as T %nonassoc '>' '<' %left '+' '-' NEG POS %left '*' '/' -%left send recv connect create +%left send recv connect create accept %nonassoc APP @@ -168,8 +169,9 @@ Exp : let var '=' Exp in Exp %prec LET { Let $2 $4 $6 } | fork Exp { Fork $2 } | send Exp %prec send { Send $2 } | recv Exp %prec recv { Recv $2 } - | create Exp Typ %prec create { Create $2 $3 } - | connect Exp Exp Typ %prec connect { Connect $2 $3 $4 } + | create Exp %prec create { Create $2 } + | connect Exp Exp Typ %prec connect { Connect $2 $3 $4} + | accept Exp Typ %prec accept { Accept $2 $3 } | Exp Exp %prec APP { App $1 $2 } Labs : lab { [$1] } diff --git a/src/Parsing/Tokens.x b/src/Parsing/Tokens.x index bb63032..e5361d3 100644 --- a/src/Parsing/Tokens.x +++ b/src/Parsing/Tokens.x @@ -44,6 +44,7 @@ tokens :- recv { tok $ const Recv } create { tok $ const Create } connect { tok $ const Connect } + accept { tok $ const Accept } -- for Binary Session Types; obsolete for Label Dependent ones select { tok $ const Select } @@ -100,6 +101,7 @@ data Token = Recv | Create | Connect | + Accept | -- for Binary Session Types; obsolete for Label Dependent ones Select | diff --git a/src/PrettySyntax.hs b/src/PrettySyntax.hs index 8be5364..0dc06fd 100644 --- a/src/PrettySyntax.hs +++ b/src/PrettySyntax.hs @@ -60,6 +60,7 @@ instance Pretty Type where pretty TDyn = pretty "★" pretty TDouble = pretty "Double" pretty TString = pretty "String" + pretty TServerSocket = pretty "ServerSocket" -- the bool indicates whether the type needs to be dualized pretty (TName b s) = (if b then pretty "~" else mempty) <> pretty s pretty (TVar b s) = (if b then pretty "~" else mempty) <> brackets (pretty s) @@ -123,8 +124,9 @@ instance Pretty Exp where pretty (New t) = pretty "new" <+> pretty t pretty (Send e) = pretty "send" <+> pretty e pretty (Recv e) = pretty "recv" <+> pretty e - pretty (Create i t) = pretty "create" <+> pretty i + pretty (Create i) = pretty "create" <+> pretty i pretty (Connect a i t) = pretty "connect" <+> pretty a <+> pretty i <+> pretty t + pretty (Accept s t) = pretty "accept" <+> pretty s <+> pretty t pretty (Case e ses) = pcase e ses pretty (Cast e t1 t2) = @@ -175,6 +177,7 @@ instance Pretty Value where VFuncCast v ft1 ft2 -> pretty "(" <+> pretty v <+> pretty " : " <+> pretty ft1 <+> pretty " ⇒ " <+> pretty ft2 <+> pretty ")" VRec {} -> pretty "VRec" VNewNatRec {} -> pretty "VNewNatRec" + VServerSocket s -> pretty "VServerSocket" instance Pretty FuncType where pretty (FuncType _ s t1 t2) = pretty "Π(" <+> pretty s <+> pretty ":" <+> pretty t1 <+> pretty ")" <+> pretty t2 diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index d58964a..061c8a3 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -3,11 +3,14 @@ module ProcessEnvironment where import Syntax as S import Control.Concurrent.Chan as C +import Control.Concurrent.MVar as MVar import Control.Monad.Reader as T import Data.Set (Set) import qualified Data.Set as Set import Kinds (Multiplicity(..)) +import Network.Socket + -- | the interpretation monad type InterpretM a = T.ReaderT PEnv IO a @@ -52,6 +55,7 @@ data Value | VFuncCast Value FuncType FuncType -- (Value : (ρ,α,Π(x:A)A') => (ρ,α,Π(x:B)B')) | VRec PEnv String String Exp Exp | VNewNatRec PEnv String String String Type Exp String Exp + | VServerSocket (MVar.MVar Socket) deriving Eq instance Show Value where @@ -70,6 +74,7 @@ instance Show Value where VFuncCast v ft1 ft2 -> "VFuncCast (" ++ show v ++ ") (" ++ show ft1 ++ ") (" ++ show ft2 ++ ")" VRec env f x e1 e0 -> "VRec " ++ " " ++ f ++ " " ++ x ++ " " ++ show e1 ++ " " ++ show e0 VNewNatRec env f n tid ty ez x es -> "VNewNatRec " ++ f ++ n ++ tid ++ show ty ++ show ez ++ x ++ show es + VServerSocket _ -> "VServerSocket" class Subtypeable t where isSubtypeOf :: t -> t -> Bool diff --git a/src/Syntax.hs b/src/Syntax.hs index a7a1a89..4c5df4d 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -33,8 +33,9 @@ data Exp = Let Ident Exp Exp | Case Exp [(String, Exp)] | Cast Exp Type Type -- New types - | Create Exp Type -- Create Port Type + | Create Exp -- Create Port | Connect Exp Exp Type -- Connect URL Port Type + | Accept Exp Type -- Accept Socket Type deriving (Show,Eq) data MathOp e @@ -75,6 +76,7 @@ data Type | TCase Exp [(String, Type)] | TEqn Exp Exp Type | TSingle Ident -- same value (and type) as ident + | TServerSocket deriving (Show) dualof :: Type -> Type @@ -168,8 +170,9 @@ instance Freevars Exp where fv (New ty) = fv ty fv (Send e1) = fv e1 fv (Recv e1) = fv e1 - fv (Create e1 ty) = fv e1 <> fv ty + fv (Create e1) = fv e1 fv (Connect e1 e2 ty) = fv e1 <> fv e2 <> fv ty + fv (Accept e1 ty) = fv e1 <> fv ty fv (Case e cases) = foldl' (<>) (fv e) $ map (fv . snd) cases fv (Cast e t1 t2) = fv e fv (Succ e) = fv e @@ -236,8 +239,9 @@ instance Substitution Exp where sb (New t) = New t sb (Send e1) = Send (sb e1) sb (Recv e1) = Recv (sb e1) - sb (Create e1 t) = Create (sb e1) t + sb (Create e1) = Create (sb e1) sb (Connect e1 e2 t) = Connect (sb e1) (sb e2) t + sb (Accept e1 t) = Accept (sb e1) t sb (Succ e1) = Succ (sb e1) sb (NatRec e ez y t z tyz es) = NatRec (sb e) (sb ez) y t z (subst x exp tyz) (if x /= y && x /= z then sb es else es) diff --git a/src/TCTyping.hs b/src/TCTyping.hs index c38042f..7a2693a 100644 --- a/src/TCTyping.hs +++ b/src/TCTyping.hs @@ -70,6 +70,7 @@ kiSynth te (TVar b v) = do kentry <- TC.kindLookup v let k = keKind kentry return (k, mult k) +kiSynth te TServerSocket = return (Kun, MMany) kiSynth te ty = TC.mfail ("kiSynth fails on " ++ pshow ty) @@ -242,10 +243,12 @@ tySynth te e = kiCheck (demoteTE te) ty Kssn return (TPair "" ty (dualof ty), te) -- I've got no real clue of what I am doing here hope it kind of works - Create e1 ty -> do + Create e1 -> do + return (TServerSocket, te) + Connect e1 e2 ty -> do kiCheck (demoteTE te) ty Kssn return (ty, te) - Connect e1 e2 ty -> do + Accept e1 ty -> do kiCheck (demoteTE te) ty Kssn return (ty, te) Send e1 -> do From 256ced139ae3158d461d27289c567f9a5e277e2c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 28 Nov 2022 17:31:13 +0100 Subject: [PATCH 017/229] Added Server Implementation that could support multible clients --- src/Interpreter.hs | 27 +++++++++++++++++++++------ src/ProcessEnvironment.hs | 3 ++- 2 files changed, 23 insertions(+), 7 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index bd960a6..8ed2bf1 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -13,6 +13,7 @@ import Syntax import PrettySyntax import qualified Control.Concurrent.Chan as Chan import qualified Control.Concurrent.MVar as MVar +import Network.Socket import Control.Concurrent (forkIO) import Data.Foldable (find) import Data.Maybe (fromJust) @@ -163,10 +164,23 @@ eval = \case val <- interpret' e case val of VInt port -> do - mvar <- liftIO MVar.newEmptyMVar - liftIO $ forkIO $ runTCPServer Nothing (show port) (NC.getSocket mvar) + -- mvar <- liftIO MVar.newEmptyMVar + sock <- liftIO $ socket AF_INET Stream 0 + liftIO $ setSocketOption sock ReuseAddr 1 + -- bind sock (SockAddrInet 4242 iNADDR_ANY) + -- let portNumber = read (show port) :: PortNumber + -- liftIO $ bind sock (SockAddrInet portNumber 0x0100007f) -- Yay terrible hacks to get code that should be simple working, what a day to be alive + let hints = defaultHints { + addrFlags = [AI_PASSIVE] + , addrSocketType = Stream + } + addrInfo <- liftIO $ getAddrInfo (Just hints) Nothing $ Just $ show port + + liftIO $ bind sock $ addrAddress $ head addrInfo + liftIO $ listen sock 2 liftIO $ C.traceIO "Server created" - return $ VServerSocket mvar + -- return $ VServerSocket mvar + return $ VServerSocket sock _ -> throw $ NotAnExpectedValueException "VInt" val Accept e t -> do @@ -176,10 +190,11 @@ eval = \case val <- interpret' e case val of - VServerSocket socketMVar -> do - socket <- liftIO $ MVar.readMVar socketMVar + VServerSocket socketRaw -> do + -- socket <- liftIO $ MVar.readMVar socketMVar + socket <- liftIO $ accept socketRaw liftIO $ C.traceIO "Aquired socket" - liftIO $ forkIO $ NC.communicate r w socket + liftIO $ forkIO $ NC.communicate r w $ fst socket liftIO $ C.traceIO "Client accepted" _ -> throw $ NotAnExpectedValueException "VServerSocket" val return $ VChan r w diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index 061c8a3..eab7074 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -55,7 +55,8 @@ data Value | VFuncCast Value FuncType FuncType -- (Value : (ρ,α,Π(x:A)A') => (ρ,α,Π(x:B)B')) | VRec PEnv String String Exp Exp | VNewNatRec PEnv String String String Type Exp String Exp - | VServerSocket (MVar.MVar Socket) + -- | VServerSocket (MVar.MVar Socket) + | VServerSocket Socket deriving Eq instance Show Value where From 537d1e4479328918f5871adb61f90477c8ec15d1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 29 Nov 2022 19:48:52 +0100 Subject: [PATCH 018/229] Better client networking --- src/Interpreter.hs | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 8ed2bf1..29df1f0 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -14,6 +14,7 @@ import PrettySyntax import qualified Control.Concurrent.Chan as Chan import qualified Control.Concurrent.MVar as MVar import Network.Socket +-- import qualified Network.Socket as NSocket import Control.Concurrent (forkIO) import Data.Foldable (find) import Data.Maybe (fromJust) @@ -210,11 +211,25 @@ eval = \case portVal <- interpret' e2 case portVal of VInt port -> do - liftIO $ forkIO $ runTCPClient address (show port) (NC.communicate r w) + -- socketmvar <- liftIO newEmptyMVar + -- liftIO $ forkIO $ runTCPClient address (show port) $ putMVar socketmvar + -- socket <- liftIO $ readMVar socketmvar + -- liftIO $ forkIO $ NC.communicate r w socket + -- liftIO $ forkIO $ runTCPClient address (show port) (NC.communicate r w) + let hints = defaultHints { + addrFlags = [] + , addrSocketType = Stream + } + addrInfo <- liftIO $ getAddrInfo (Just hints) (Just address) $ Just $ show port + clientsocket <- liftIO $ openSocket $ head addrInfo + liftIO $ connect clientsocket $ addrAddress $ head addrInfo + liftIO $ forkIO $ NC.communicate r w clientsocket liftIO $ C.traceIO "Client connected" _ -> throw $ NotAnExpectedValueException "VInt" portVal _ -> throw $ NotAnExpectedValueException "VString" addressVal return $ VChan r w + where + openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) e -> throw $ NotImplementedException e -- Exp is only used for blame From 2af69c24f15ade033ce10e83b807e99712d116b2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 29 Nov 2022 20:12:55 +0100 Subject: [PATCH 019/229] progress towards explicit send support --- src/Interpreter.hs | 13 ++++++++----- src/Networking/Common.hs | 23 +++++++++++++++++++++++ src/PrettySyntax.hs | 2 +- src/ProcessEnvironment.hs | 5 +++-- 4 files changed, 35 insertions(+), 8 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 29df1f0..c049252 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -151,10 +151,10 @@ eval = \case New t -> do r <- liftIO Chan.newChan w <- liftIO Chan.newChan - return $ VPair (VChan r w) (VChan w r) + return $ VPair (VChan r w Nothing) (VChan w r Nothing) Send e -> VSend <$> interpret' e -- Apply VSend to the output of interpret' e Recv e -> do - interpret' e >>= \v@(VChan c _) -> do + interpret' e >>= \v@(VChan c _ _) -> do val <- liftIO $ Chan.readChan c liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e return $ VPair val v @@ -198,7 +198,7 @@ eval = \case liftIO $ forkIO $ NC.communicate r w $ fst socket liftIO $ C.traceIO "Client accepted" _ -> throw $ NotAnExpectedValueException "VServerSocket" val - return $ VChan r w + return $ VChan r w Nothing Connect e1 e2 t -> do r <- liftIO Chan.newChan @@ -227,7 +227,7 @@ eval = \case liftIO $ C.traceIO "Client connected" _ -> throw $ NotAnExpectedValueException "VInt" portVal _ -> throw $ NotAnExpectedValueException "VString" addressVal - return $ VChan r w + return $ VChan r w Nothing where openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) e -> throw $ NotImplementedException e @@ -263,8 +263,11 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) | n > 0 = do let env' = extendEnv n1 (VInt (n-1)) (extendEnv f natrec env) R.local (const env') (interpret' es) -interpretApp _ (VSend v@(VChan _ c)) w = do +interpretApp _ (VSend v@(VChan _ c handle)) w = do liftIO (Chan.writeChan c w) + case handle of + Nothing -> pure () + Just hdl -> liftIO $ NC.sendMessage w hdl liftIO $ threadDelay 100000 -- give send thread time to send -- I obviously need to remove this ugly hack return v diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index eee4322..9c69ce3 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -38,6 +38,29 @@ communicate read write socket = do recieveReadable read handle +sendMessage :: Value -> Handle -> IO () +sendMessage value handle = do + putStrLn $ "Sending message:" ++ SV.serialize value + hPutStrLn handle (SV.serialize value ++" ") + + +recieveMessages :: Chan.Chan Value -> Handle -> IO () +recieveMessages chan handle = do + message <- hGetLine handle + putStrLn $ "Recieved message:" ++ message + case VT.runAlex message VG.parseValues of + Left err -> putStrLn $ "Error during recieving a networkmessage: "++err + Right deserial -> writeChan chan deserial + recieveMessages chan handle + + +getHandle :: Socket -> IO Handle +getHandle socket = do + hdl <- socketToHandle socket ReadWriteMode + hSetBuffering hdl NoBuffering + return hdl + + getSocket :: MVar.MVar Socket -> Socket -> IO () getSocket mvar socket = do putStrLn "Trying to send socket" diff --git a/src/PrettySyntax.hs b/src/PrettySyntax.hs index 0dc06fd..8bc25f8 100644 --- a/src/PrettySyntax.hs +++ b/src/PrettySyntax.hs @@ -168,7 +168,7 @@ instance Pretty Value where VInt i -> pretty $ show i VDouble d -> pretty $ show d VString s -> pretty $ show s - VChan _ _ -> pretty "VChan" + VChan {} -> pretty "VChan" VSend v -> pretty "VSend" VPair a b -> pretty "<" <+> pretty a <+> pretty ", " <+> pretty b <+> pretty ">" VType t -> pretty t diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index eab7074..b8c9716 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -2,6 +2,7 @@ module ProcessEnvironment where import Syntax as S +import GHC.IO.Handle import Control.Concurrent.Chan as C import Control.Concurrent.MVar as MVar import Control.Monad.Reader as T @@ -45,7 +46,7 @@ data Value | VString String -- we have two channels, one for reading and one for writing to the other -- end, so we do not read our own written values - | VChan (C.Chan Value) (C.Chan Value) + | VChan (C.Chan Value) (C.Chan Value) (Maybe Handle) -- | VChan (C.Chan Value) (C.Chan Value) | VSend Value | VPair Value Value -- pair of ids that map to two values @@ -66,7 +67,7 @@ instance Show Value where VInt i -> "VInt " ++ show i VDouble d -> "VDouble " ++ show d VString s -> "VString \"" ++ show s ++ "\"" - VChan _ _ -> "VChan" + VChan {} -> "VChan" VSend v -> "VSend (" ++ show v ++ ")" VPair a b -> "VPair <" ++ show a ++ ", " ++ show b ++ ">" VType t -> "VType " ++ show t From ea019ea494d96e6296ae5f66fac7967cbe6e2af3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 29 Nov 2022 20:20:10 +0100 Subject: [PATCH 020/229] Explicit send works now --- src/Interpreter.hs | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index c049252..683d497 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -195,10 +195,12 @@ eval = \case -- socket <- liftIO $ MVar.readMVar socketMVar socket <- liftIO $ accept socketRaw liftIO $ C.traceIO "Aquired socket" - liftIO $ forkIO $ NC.communicate r w $ fst socket + handle <- liftIO $ NC.getHandle $ fst socket + liftIO $ forkIO $ NC.recieveMessages r handle + -- liftIO $ forkIO $ NC.communicate r w $ fst socket liftIO $ C.traceIO "Client accepted" + return $ VChan r w $ Just handle _ -> throw $ NotAnExpectedValueException "VServerSocket" val - return $ VChan r w Nothing Connect e1 e2 t -> do r <- liftIO Chan.newChan @@ -223,11 +225,13 @@ eval = \case addrInfo <- liftIO $ getAddrInfo (Just hints) (Just address) $ Just $ show port clientsocket <- liftIO $ openSocket $ head addrInfo liftIO $ connect clientsocket $ addrAddress $ head addrInfo - liftIO $ forkIO $ NC.communicate r w clientsocket + -- liftIO $ forkIO $ NC.communicate r w clientsocket + handle <- liftIO $ NC.getHandle clientsocket + liftIO $ forkIO $ NC.recieveMessages r handle liftIO $ C.traceIO "Client connected" + return $ VChan r w $ Just handle _ -> throw $ NotAnExpectedValueException "VInt" portVal _ -> throw $ NotAnExpectedValueException "VString" addressVal - return $ VChan r w Nothing where openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) e -> throw $ NotImplementedException e @@ -268,7 +272,7 @@ interpretApp _ (VSend v@(VChan _ c handle)) w = do case handle of Nothing -> pure () Just hdl -> liftIO $ NC.sendMessage w hdl - liftIO $ threadDelay 100000 -- give send thread time to send + -- liftIO $ threadDelay 100000 -- give send thread time to send -- I obviously need to remove this ugly hack return v interpretApp e _ _ = throw $ ApplicationException e From 2d1716a95e9773fdd682f8fbcb5bba5e440376a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 30 Nov 2022 12:17:27 +0100 Subject: [PATCH 021/229] Added new serializer --- ldgv.cabal | 3 + package.yaml | 1 + src/Interpreter.hs | 2 - src/Networking/Common.hs | 10 +- src/Networking/Serialize.hs | 231 ++++++++++++++++++++++++++++++++++++ src/Networking/UserID.hs | 15 +++ 6 files changed, 256 insertions(+), 6 deletions(-) create mode 100644 src/Networking/Serialize.hs create mode 100644 src/Networking/UserID.hs diff --git a/ldgv.cabal b/ldgv.cabal index 3d25cf1..8020c32 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -70,7 +70,9 @@ library Networking.DirectionalConnection Networking.Messages Networking.NetworkConnection + Networking.Serialize Networking.Server + Networking.UserID Parsing Parsing.Grammar Parsing.Tokens @@ -106,6 +108,7 @@ library , network , network-run , prettyprinter + , random , text , transformers , typed-process diff --git a/package.yaml b/package.yaml index 231b484..e74a555 100644 --- a/package.yaml +++ b/package.yaml @@ -62,6 +62,7 @@ library: - validation-selective - network - network-run + - random tests: ldgv-test: diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 683d497..6772c48 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -272,8 +272,6 @@ interpretApp _ (VSend v@(VChan _ c handle)) w = do case handle of Nothing -> pure () Just hdl -> liftIO $ NC.sendMessage w hdl - -- liftIO $ threadDelay 100000 -- give send thread time to send - -- I obviously need to remove this ugly hack return v interpretApp e _ _ = throw $ ApplicationException e diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 9c69ce3..73ff8ff 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -11,11 +11,12 @@ import qualified Control.Concurrent.Chan as Chan import qualified Control.Concurrent.MVar as MVar import ProcessEnvironment +import qualified Networking.Serialize as NSerialize import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG -import qualified SerializeValues as SV +{- -- communicate :: Chan.Chan Value -> Chan.Chan Value -> Socket -> IO () communicate read write socket = do hdl <- socketToHandle socket ReadWriteMode @@ -36,12 +37,13 @@ communicate read write socket = do Left err -> putStrLn $ "Error during recieving a networkmessage: "++err Right deserial -> writeChan read deserial recieveReadable read handle - +-} sendMessage :: Value -> Handle -> IO () sendMessage value handle = do - putStrLn $ "Sending message:" ++ SV.serialize value - hPutStrLn handle (SV.serialize value ++" ") + serializedValue <- NSerialize.serialize value + putStrLn $ "Sending message:" ++ serializedValue + hPutStrLn handle (serializedValue ++" ") recieveMessages :: Chan.Chan Value -> Handle -> IO () diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs new file mode 100644 index 0000000..82c81fd --- /dev/null +++ b/src/Networking/Serialize.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} + +module Networking.Serialize where + +import Control.Monad.IO.Class +import Control.Concurrent.Chan as Chan +import Syntax +import Kinds +import qualified Syntax as S +import Data.Set +import Foreign.C (eNODEV, e2BIG) +import Control.Concurrent (getChanContents) +import Control.Exception +import ProcessEnvironment + + +newtype SerializationException = UnserializableException String + deriving Eq + +instance Show SerializationException where + show = \case + (UnserializableException s) -> "UnserializableException: " ++ s ++ " is not serializable" + +instance Exception SerializationException + + +class Serializable a where + serialize :: a -> IO String + +instance Serializable Value where + serialize = \case + VUnit -> return "VUnit" + VLabel s -> serializeLabeledEntry "VLabel" s + VInt i -> serializeLabeledEntry "VInt" i + VDouble d -> serializeLabeledEntry "VDouble" d + VString s -> serializeLabeledEntry "VString" s + VSend v -> serializeLabeledEntry "VSend" v + VPair a b -> serializeLabeledEntryMulti "VPair" a $ sLast b + VType t -> serializeLabeledEntry "VType" t + VFunc env s exp -> serializeLabeledEntryMulti "VFunc" env $ sNext s $ sLast exp + VDynCast v t -> serializeLabeledEntryMulti "VDynCast" v $ sLast t + VFuncCast v ft1 ft2 -> serializeLabeledEntryMulti "VFuncCast" v $ sNext ft1 $ sLast ft2 + VRec env f x e0 e1 -> serializeLabeledEntryMulti "VRec" env $ sNext f $ sNext x $ sNext e0 $ sLast e1 + VNewNatRec env f n tid ty ez x es -> serializeLabeledEntryMulti "VNewNatRec" env $ sNext f $ sNext n $ sNext tid $ sNext ty $ sNext ez $ sNext x $ sLast es + + VServerSocket _ -> throw $ UnserializableException "VServerSocket" + VChan {} -> throw $ UnserializableException "VChan" + +instance Serializable Multiplicity where + serialize = \case + MMany -> return "MMany" + MOne -> return "MOne" + +instance Serializable Type where + serialize = \case + TUnit -> return "TUnit" + TInt -> return "TInt" + TDouble -> return "TDouble" + TBot -> return "TBot" + TDyn -> return "TDyn" + TNat -> return "TNat" + TString -> return "TString" + TNatLeq i -> serializeLabeledEntry "TNatLeq" i + TNatRec e t1 ident t2 -> serializeLabeledEntryMulti "TNatRec" e $ sNext t1 $ sNext ident $ sLast t2 + TVar b ident -> serializeLabeledEntryMulti "TVar" b $ sLast ident + TAbs ident t1 t2 -> serializeLabeledEntryMulti "TAbs" ident $ sNext t1 $ sLast t2 + TName b ident -> serializeLabeledEntryMulti "TName" b $ sLast ident + TLab arr -> serializeLabeledEntry "TLab" arr + TFun mult ident t1 t2 -> serializeLabeledEntryMulti "TFun" mult $ sNext ident $ sNext t1 $ sLast t2 + TPair ident t1 t2 -> serializeLabeledEntryMulti "TPair" ident $ sNext t1 $ sLast t2 + TSend ident t1 t2 -> serializeLabeledEntryMulti "TSend" ident $ sNext t1 $ sLast t2 + TRecv ident t1 t2 -> serializeLabeledEntryMulti "TRecv" ident $ sNext t1 $ sLast t2 + TCase e arr -> serializeLabeledEntryMulti "TCase" e $ sLast arr + TEqn e1 e2 t -> serializeLabeledEntryMulti "TEqn" e1 $ sNext e2 $ sLast t + TSingle ident -> serializeLabeledEntry "TSingle" ident + + TServerSocket -> return "TServerSocket" + +instance Serializable Exp where + serialize = \case + Let ident e1 e2 -> serializeLabeledEntryMulti "ELet" ident $ sNext e1 $ sLast e2 + Math mathop -> serializeLabeledEntry "EMath" mathop + Lit l -> serializeLabeledEntry "ELit" l + Succ e -> serializeLabeledEntry "ESucc" e + NatRec e1 e2 ident1 ident2 ident3 t e3 -> serializeLabeledEntryMulti "NatRec" e1 $ sNext e2 $ sNext ident1 $ sNext ident2 $ sNext ident3 $ sNext t $ sLast e3 + NewNatRec ident1 ident2 ident3 t e1 ident4 e2 -> serializeLabeledEntryMulti "ENewNatRec" ident1 $ sNext ident2 $ sNext ident3 $ sNext t $ sNext e1 $ sNext ident4 $ sLast e2 + Var ident -> serializeLabeledEntry "EVar" ident + Lam mult ident t e -> serializeLabeledEntryMulti "ELam" mult $ sNext ident $ sNext t $ sLast e + Rec ident1 ident2 e1 e2 -> serializeLabeledEntryMulti "ERec" ident1 $ sNext ident2 $ sNext e1 $ sLast e2 + App e1 e2 -> serializeLabeledEntryMulti "EApp" e1 $ sLast e2 + Pair mult ident e1 e2 -> serializeLabeledEntryMulti "EPair" mult $ sNext ident $ sNext e1 $ sLast e2 + LetPair ident1 ident2 e1 e2 -> serializeLabeledEntryMulti "ELetPair" ident1 $ sNext ident2 $ sNext e1 $ sLast e2 + Fst e -> serializeLabeledEntry "EFst" e + Snd e -> serializeLabeledEntry "ESnd" e + Fork e -> serializeLabeledEntry "EFork" e + New t -> serializeLabeledEntry "ENew" t + Send e -> serializeLabeledEntry "ESend" e + Recv e -> serializeLabeledEntry "ERecv" e + Case e arr -> serializeLabeledEntryMulti "ECase" e $ sLast arr + Cast e t1 t2 -> serializeLabeledEntryMulti "ECast" e $ sNext t1 $ sLast t2 + + Create e -> serializeLabeledEntry "ECreate" e + Connect e1 e2 t -> serializeLabeledEntryMulti "EConnect" e1 $ sNext e2 $ sLast t + Accept e t -> serializeLabeledEntryMulti "EAccept" e $ sLast t + +instance Serializable (MathOp Exp) where + serialize = \case + Add e1 e2 -> serializeLabeledEntryMulti "MAdd" e1 $ sLast e2 + Sub e1 e2 -> serializeLabeledEntryMulti "MSub" e1 $ sLast e2 + Mul e1 e2 -> serializeLabeledEntryMulti "MMul" e1 $ sLast e2 + Div e1 e2 -> serializeLabeledEntryMulti "MDiv" e1 $ sLast e2 + Neg e -> serializeLabeledEntry "MNeg" e +instance Serializable Literal where + serialize = \case + LInt i -> serializeLabeledEntry "LInt" i + LNat i -> serializeLabeledEntry "LNat" i + LDouble d -> serializeLabeledEntry "LDouble" d + LLab s -> serializeLabeledEntry "LLab" s + LUnit -> return "LUnit" + LString s -> serializeLabeledEntry "LString" s + +instance Serializable FuncType where + serialize (FuncType env s t1 t2) = serializeLabeledEntryMulti "SFuncType" env $ sNext s $ sNext t1 $ sLast t2 -- do + -- envs <- serialize env + -- ss <- serialize s + -- t1s <- serialize t1 + -- t2s <- serialize t2 + -- return $ "SFuncType (" ++ envs ++ ") (" ++ ss ++ ") (" ++ t1s ++ ") (" ++ t2s ++ ")" + +instance Serializable GType where + serialize = \case + GUnit -> return "GUnit" + GLabel lt -> serializeLabeledEntry "GLabel" lt + GFunc mult -> serializeLabeledEntry "GFunc" mult + GPair -> return "GPair" + GNat -> return "GNat" + GNatLeq i -> serializeLabeledEntry "GNatLeq" i + GInt -> return "GInt" + GDouble -> return "GDouble" + GString -> return "GString" + +sLast :: Serializable a => a -> IO String +sLast x = sNext x $ return "" + +sNext :: Serializable a => a -> IO String -> IO String +sNext x ios = do + xString <- serialize x + iosString <- ios + return $ " (" ++ xString ++ ")" ++ iosString + +serializeLabeledEntryMulti :: Serializable a => String -> a -> IO String -> IO String +serializeLabeledEntryMulti label x ios = do + xString <- serialize x + iosString <- ios + return $ label ++ " (" ++ xString ++ ")" ++ iosString + +serializeLabeledEntry :: Serializable a => String -> a -> IO String +serializeLabeledEntry label x = do + xString <- serialize x + return $ label ++ " (" ++ xString ++ ")" + +instance {-# OVERLAPPING #-} Serializable String where + serialize s = return $ "String:"++ show s + +instance Serializable Int where + serialize i = return $ "Int:" ++ show i + +instance Serializable Integer where + serialize i = return $ "Integer:" ++ show i + +instance Serializable Bool where + serialize b = return $ "Bool:" ++ show b + +instance Serializable Double where + serialize d = return $ "Double:" ++ show d + +-- instance (Serializable a => Serializable (Set a)) where +-- serialize as = "{" ++ serializeElements (elems as) ++ "}" + +-- instance {-# OVERLAPPABLE #-} (Serializable a => Serializable [a]) where +-- serialize arr = "["++ serializeElements arr ++"]" + +instance ((Serializable a, Serializable b) => Serializable (a, b)) where + serialize (s, t) = do + ss <- serialize s + ts <- serialize t + return $ "((" ++ ss ++ ") (" ++ ts ++ "))" + +instance {-# OVERLAPPING #-} Serializable PEnv where + serialize arr = serializeLabeledArray "PEnv" arr + +instance {-# OVERLAPPING #-} Serializable PEnvEntry where + serialize (s, t) = do + ss <- serialize s + ts <- serialize t + return $ "PEnvEntry (" ++ ss ++ ") (" ++ ts ++ ")" + +instance {-# OVERLAPPING #-} Serializable LabelType where + serialize as = serializeLabeledArray "SLabelType" (elems as) + +instance {-# OVERLAPPING #-} Serializable [(String, Exp)] where + serialize arr = serializeLabeledArray "SStringExpArray" arr + +instance {-# OVERLAPPING #-} Serializable [(String, Type)] where + serialize arr = serializeLabeledArray "SStringTypeArray" arr + +instance {-# OVERLAPPING #-} Serializable [String] where + serialize arr = serializeLabeledArray "SStringArray" arr + +instance {-# OVERLAPPING #-}Serializable [Value] where + serialize arr = serializeLabeledArray "SValuesArray" arr + + +instance Serializable (Chan.Chan Value) where + serialize c = do + ccnt <- getChanContents c + serialize ccnt + +serializeLabeledArray :: Serializable a => String -> [a] -> IO String +serializeLabeledArray label arr = do + elems <- serializeElements arr + return $ label ++ " [" ++ elems ++ "]" + +serializeElements :: Serializable a => [a] -> IO String +serializeElements [] = return "" +serializeElements [x] = serialize x +serializeElements (x:xs) = do + h <- serialize x + t <- serializeElements xs + return $ h ++ ", " ++ t \ No newline at end of file diff --git a/src/Networking/UserID.hs b/src/Networking/UserID.hs new file mode 100644 index 0000000..d9e0e24 --- /dev/null +++ b/src/Networking/UserID.hs @@ -0,0 +1,15 @@ +module Networking.UserID where + +import Data.Char +import System.Random + +mapToChar :: Int -> Char +mapToChar val + | 0 <= val && val <= 9 = chr (val + 48) + | 10 <= val && val <= 35 = chr (val + 55) + | 36 <= val && val <= 61 = chr (val + 61) + | otherwise = '-' + +-- This is "probably" unique +newRandomUserID :: IO String +newRandomUserID = map mapToChar . take 128 . randomRs (0, 61) <$> getStdGen From 5bb5d383b142147206fb7b060b3e947e7583010a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 30 Nov 2022 15:16:12 +0100 Subject: [PATCH 022/229] Added networking messages Added networking messages, they are currently unused though --- src/Interpreter.hs | 10 +++++----- src/Networking/Common.hs | 8 ++++++++ src/Networking/Messages.hs | 7 ++++--- src/Networking/Serialize.hs | 9 +++++++++ src/ProcessEnvironment.hs | 3 ++- src/ValueParsing/ValueGrammar.y | 15 +++++++++++++++ src/ValueParsing/ValueTokens.x | 12 ++++++++++++ 7 files changed, 55 insertions(+), 9 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 6772c48..6287ef1 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -151,10 +151,10 @@ eval = \case New t -> do r <- liftIO Chan.newChan w <- liftIO Chan.newChan - return $ VPair (VChan r w Nothing) (VChan w r Nothing) + return $ VPair (VChan r w Nothing Nothing Nothing Nothing) (VChan w r Nothing Nothing Nothing Nothing) Send e -> VSend <$> interpret' e -- Apply VSend to the output of interpret' e Recv e -> do - interpret' e >>= \v@(VChan c _ _) -> do + interpret' e >>= \v@(VChan c _ _ _ _ _) -> do val <- liftIO $ Chan.readChan c liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e return $ VPair val v @@ -199,7 +199,7 @@ eval = \case liftIO $ forkIO $ NC.recieveMessages r handle -- liftIO $ forkIO $ NC.communicate r w $ fst socket liftIO $ C.traceIO "Client accepted" - return $ VChan r w $ Just handle + return $ VChan r w (Just handle) (Just $ snd socket) Nothing Nothing _ -> throw $ NotAnExpectedValueException "VServerSocket" val Connect e1 e2 t -> do @@ -229,7 +229,7 @@ eval = \case handle <- liftIO $ NC.getHandle clientsocket liftIO $ forkIO $ NC.recieveMessages r handle liftIO $ C.traceIO "Client connected" - return $ VChan r w $ Just handle + return $ VChan r w (Just handle) (Just $ addrAddress $ head addrInfo) Nothing Nothing _ -> throw $ NotAnExpectedValueException "VInt" portVal _ -> throw $ NotAnExpectedValueException "VString" addressVal where @@ -267,7 +267,7 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) | n > 0 = do let env' = extendEnv n1 (VInt (n-1)) (extendEnv f natrec env) R.local (const env') (interpret' es) -interpretApp _ (VSend v@(VChan _ c handle)) w = do +interpretApp _ (VSend v@(VChan _ c handle _ _ _)) w = do liftIO (Chan.writeChan c w) case handle of Nothing -> pure () diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 73ff8ff..d06452b 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -4,8 +4,11 @@ import qualified Control.Exception as E import qualified Data.ByteString.Char8 as C import Network.Socket import Network.Socket.ByteString (recv, sendAll) +import Data.Map (Map) +import qualified Data.Map as Map import Control.Concurrent import GHC.IO.Handle +import Control.Monad.IO.Class import System.IO import qualified Control.Concurrent.Chan as Chan import qualified Control.Concurrent.MVar as MVar @@ -39,6 +42,11 @@ communicate read write socket = do recieveReadable read handle -} +userIDToHandle :: MVar.MVar (Map.Map String Handle) -> String -> IO (Maybe Handle) +userIDToHandle mvar userid = do + useridmap <- readMVar mvar + return $ Map.lookup userid useridmap + sendMessage :: Value -> Handle -> IO () sendMessage value handle = do serializedValue <- NSerialize.serialize value diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs index fae75df..13e0c98 100644 --- a/src/Networking/Messages.hs +++ b/src/Networking/Messages.hs @@ -6,8 +6,9 @@ type Partner = String type Hostname = String type Port = Int -data Message - = NewValue Partner Value - | SyncIncomming Partner [Value] +data Messages + = Introduce Partner + | NewValue Partner Value + | SyncIncoming Partner [Value] | RequestSync Partner | ChangePartnerAddress Partner Hostname Port diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index 82c81fd..1b7110e 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -13,6 +13,7 @@ import Foreign.C (eNODEV, e2BIG) import Control.Concurrent (getChanContents) import Control.Exception import ProcessEnvironment +import Networking.Messages newtype SerializationException = UnserializableException String @@ -28,6 +29,14 @@ instance Exception SerializationException class Serializable a where serialize :: a -> IO String +instance Serializable Messages where + serialize = \case + Introduce p -> serializeLabeledEntry "NIntroduce" p + NewValue p v -> serializeLabeledEntryMulti "NNewValue" p $ sLast v + SyncIncoming p vs -> serializeLabeledEntryMulti "NSyncIncoming" p $ sLast vs + RequestSync p -> serializeLabeledEntry "NRequestSync" p + ChangePartnerAddress p h port -> serializeLabeledEntryMulti "NChangePartnerAddress" p $ sNext h $ sLast port + instance Serializable Value where serialize = \case VUnit -> return "VUnit" diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index b8c9716..e11d99b 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -46,7 +46,8 @@ data Value | VString String -- we have two channels, one for reading and one for writing to the other -- end, so we do not read our own written values - | VChan (C.Chan Value) (C.Chan Value) (Maybe Handle) + | VChan (C.Chan Value) (C.Chan Value) (Maybe Handle) (Maybe SockAddr) (Maybe String) (Maybe String) + -- Read Chan Write Chan Handle of Con Address of other other Userid own UserID -- | VChan (C.Chan Value) (C.Chan Value) | VSend Value | VPair Value Value -- pair of ids that map to two values diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index f948c59..096582d 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -10,6 +10,7 @@ import Syntax import ProcessEnvironment import ValueParsing.ValueTokens (T(..)) import qualified ValueParsing.ValueTokens as T +import Networking.Messages } %monad { T.Alex } @@ -21,6 +22,7 @@ import qualified ValueParsing.ValueTokens as T --%name parseType Typ %name parseValues Values +%name parseMessages Messages -- %name parseSStringTypeElement SStringTypeElement -- %name parseSStringTypeElements SStringTypeElements -- %name parseSStringTypeArray SStringTypeArray @@ -105,6 +107,12 @@ import qualified ValueParsing.ValueTokens as T sstringtypearray { T _ T.SStringTypeArray } sstringarray { T _ T.SStringArray } svaluesarray { T _ T.SValuesArray } + + nintroduce { T _ T.NIntroduce } + nnewvalue { T _ T.NNewValue } + nsyncincoming { T _ T.NSyncIncoming } + nrequestsync { T _ T.NRequestSync } + nchangepartneraddress {T _ T.NChangePartnerAddress } gunit { T _ T.GUnit } glabel { T _ T.GLabel } @@ -247,6 +255,13 @@ GType : gunit {GUnit} | gdouble {GDouble} | gstring {GString} +Messages : nintroduce '(' String ')' {Introduce $3} + | nnewvalue '(' String ')''(' Values ')' {NewValue $3 $6} + | nsyncincoming '(' String ')''(' SValuesArray ')' {SyncIncoming $3 $6} + | nrequestsync '(' String ')' {RequestSync $3} + | nchangepartneraddress '(' String ')' '(' String ')' '(' int ')' {ChangePartnerAddress $3 $6 $9} + + PEnvEntry : penventry '(' String ')' '(' Values ')' {($3, $6)} PEnv : penv '[' PEnvElements ']' { $3 } diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index 599ac4f..af31d4c 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -123,6 +123,12 @@ tokens :- "SStringArray" { tok $ const SStringArray } "SValuesArray" { tok $ const SValuesArray } + "NIntroduce" { tok $ const NIntroduce } + "NNewValue" { tok $ const NNewValue } + "NSyncIncoming" { tok $ const NSyncIncoming } + "NRequestSync" { tok $ const NRequestSync } + "NChangePartnerAddress" { tok $ const NChangePartnerAddress } + "Double:" $digit+ "." $digit+ { tok $ Double . read . (drop 7) } "Int:" $digit+ { tok $ Int . read . (drop 4)} "Integer:" $digit+ { tok $ Integer . read . (drop 8)} @@ -230,6 +236,12 @@ data Token | SStringArray | SValuesArray + | NIntroduce + | NNewValue + | NSyncIncoming + | NRequestSync + | NChangePartnerAddress + | String String | Int Int | Integer Integer From a0975feb593a6ee6db476a5d99e58effc42f77e1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 30 Nov 2022 17:33:27 +0100 Subject: [PATCH 023/229] Server code added code for managing client connections on servers. This code is not yet used or debugged --- src/Networking/Common.hs | 43 +++++++++++++++++++- src/Networking/Server.hs | 70 ++++++++++++++++++++++++++++++++- src/ValueParsing/ValueGrammar.y | 2 +- 3 files changed, 111 insertions(+), 4 deletions(-) diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index d06452b..c4523d1 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -15,6 +15,7 @@ import qualified Control.Concurrent.MVar as MVar import ProcessEnvironment import qualified Networking.Serialize as NSerialize +import Networking.Messages import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG @@ -42,10 +43,48 @@ communicate read write socket = do recieveReadable read handle -} -userIDToHandle :: MVar.MVar (Map.Map String Handle) -> String -> IO (Maybe Handle) +-- This waits until the handle is found +userIDToHandle :: MVar.MVar (Map.Map String Handle) -> String -> IO Handle userIDToHandle mvar userid = do useridmap <- readMVar mvar - return $ Map.lookup userid useridmap + case Map.lookup userid useridmap of + Just handle -> return handle + Nothing -> userIDToHandle mvar userid + +sendMessageID :: Value -> MVar.MVar (Map.Map String Handle) -> String -> IO () +sendMessageID value handlemapmvar userid = do + serializedValue <- NSerialize.serialize $ NewValue userid value + putStrLn $ "Sending message:" ++ serializedValue + handle <- userIDToHandle handlemapmvar userid + hPutStrLn handle (serializedValue ++ " ") + + {- + maybehandle <- userIDToHandle handlemapmvar userid + case maybehandle of + Just handle -> hPutStrLn handle (serializedValue ++" ") + Nothing -> putStrLn $ "Error " ++ userid ++ " not found while trying to recieve messages" + -} + +recieveMessagesID :: Chan.Chan Value -> MVar.MVar (Map.Map String Handle) -> String -> IO () +recieveMessagesID chan mvar userid = do + handle <- userIDToHandle mvar userid + message <- hGetLine handle + putStrLn $ "Recieved message:" ++ message + case VT.runAlex message VG.parseValues of + Left err -> putStrLn $ "Error during recieving a networkmessage: "++err + Right deserial -> writeChan chan deserial + {- + case maybehandle of + Just handle -> do + message <- hGetLine handle + putStrLn $ "Recieved message:" ++ message + case VT.runAlex message VG.parseValues of + Left err -> putStrLn $ "Error during recieving a networkmessage: "++err + Right deserial -> writeChan chan deserial + Nothing -> putStrLn $ "Error " ++ userid ++ " not found while trying to recieve messages" + -} + recieveMessagesID chan mvar userid + sendMessage :: Value -> Handle -> IO () sendMessage value handle = do diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index fb0e7cc..9a97fa7 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -1 +1,69 @@ -module Networking.Server where \ No newline at end of file +{-# LANGUAGE LambdaCase #-} +module Networking.Server where + +import qualified Control.Concurrent.MVar as MVar +import Control.Concurrent (forkIO) +import Control.Monad.IO.Class +import Data.Map +import GHC.IO.Handle +import Network.Socket + +import Networking.Messages +import qualified ValueParsing.ValueTokens as VT +import qualified ValueParsing.ValueGrammar as VG +import qualified Networking.Common as NC +import qualified Networking.Serialize as NSerialize + +import Control.Exception + +newtype ServerException = NoIntroductionException String + deriving Eq + +instance Show ServerException where + show = \case + NoIntroductionException s -> "Client didn't introduce itself, but sent: " ++ s + +instance Exception ServerException + + +createServer :: Int -> IO (MVar.MVar (Map String Handle)) +createServer port = do + sock <- liftIO $ socket AF_INET Stream 0 + liftIO $ setSocketOption sock ReuseAddr 1 + let hints = defaultHints { + addrFlags = [AI_PASSIVE] + , addrSocketType = Stream + } + addrInfo <- liftIO $ getAddrInfo (Just hints) Nothing $ Just $ show port + + liftIO $ bind sock $ addrAddress $ head addrInfo + liftIO $ listen sock 2 + mvar <- MVar.newEmptyMVar + MVar.putMVar mvar empty + return mvar + +acceptClients :: MVar.MVar (Map String (Handle, SockAddr)) -> Socket -> IO () +acceptClients mvar socket = do + clientsocket <- accept socket + forkIO $ acceptClient mvar clientsocket + acceptClients mvar socket + + +acceptClient :: MVar.MVar (Map String (Handle, SockAddr)) -> (Socket, SockAddr) -> IO () +acceptClient mvar clientsocket = do + hdl <- NC.getHandle $ fst clientsocket + userid <- waitForIntroduction hdl + MVar.modifyMVar_ mvar (return . insert userid (hdl, snd clientsocket)) + +waitForIntroduction :: Handle -> IO String +waitForIntroduction handle = do + message <- hGetLine handle + case VT.runAlex message VG.parseMessages of + Left err -> do + putStrLn $ "Error during client introduction: "++err + throw $ NoIntroductionException message + Right deserial -> case deserial of + Introduce partner -> return partner + _ -> do + putStrLn $ "Error during client introduction, wrong message: "++ message + throw $ NoIntroductionException message \ No newline at end of file diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 096582d..9dc40f5 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -1,5 +1,5 @@ { -module ValueParsing.ValueGrammar (parseValues) where +module ValueParsing.ValueGrammar (parseValues, parseMessages) where import Control.Monad import qualified Data.List as List From f3b54d269c3254fb7107d7798bc8299f73606c37 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 30 Nov 2022 18:31:24 +0100 Subject: [PATCH 024/229] Update Server.hs --- src/Networking/Server.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 9a97fa7..6596f1b 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -2,6 +2,7 @@ module Networking.Server where import qualified Control.Concurrent.MVar as MVar +import qualified Control.Concurrent.Chan as Chan import Control.Concurrent (forkIO) import Control.Monad.IO.Class import Data.Map @@ -42,18 +43,19 @@ createServer port = do MVar.putMVar mvar empty return mvar -acceptClients :: MVar.MVar (Map String (Handle, SockAddr)) -> Socket -> IO () -acceptClients mvar socket = do +acceptClients :: MVar.MVar (Map String (Handle, SockAddr)) -> Chan.Chan String -> Socket -> IO () +acceptClients mvar chan socket = do clientsocket <- accept socket - forkIO $ acceptClient mvar clientsocket - acceptClients mvar socket + forkIO $ acceptClient mvar chan clientsocket + acceptClients mvar chan socket -acceptClient :: MVar.MVar (Map String (Handle, SockAddr)) -> (Socket, SockAddr) -> IO () -acceptClient mvar clientsocket = do +acceptClient :: MVar.MVar (Map String (Handle, SockAddr)) -> Chan.Chan String -> (Socket, SockAddr) -> IO () +acceptClient mvar chan clientsocket = do hdl <- NC.getHandle $ fst clientsocket userid <- waitForIntroduction hdl MVar.modifyMVar_ mvar (return . insert userid (hdl, snd clientsocket)) + Chan.writeChan chan userid waitForIntroduction :: Handle -> IO String waitForIntroduction handle = do From 6ce7e7175763dac4637463caa60a42734e586a37 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 1 Dec 2022 18:02:47 +0100 Subject: [PATCH 025/229] More code towards the networking --- src/Interpreter.hs | 38 ++++++++++++++----------------------- src/Networking/Common.hs | 20 ++++++++++++++----- src/Networking/Serialize.hs | 2 +- src/Networking/Server.hs | 16 +++++++++++----- src/PrettySyntax.hs | 2 +- src/ProcessEnvironment.hs | 9 +++++++-- 6 files changed, 49 insertions(+), 38 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 6287ef1..2d85e1a 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -33,7 +33,12 @@ import qualified Networking.Common as NC import Network.Run.TCP import qualified Networking.Server as NS +import Networking.UserID as UserID + import Control.Concurrent +import qualified Networking.UserID as UserID + +import qualified Networking.Messages as Messages data InterpreterException = MathException String @@ -166,40 +171,23 @@ eval = \case case val of VInt port -> do -- mvar <- liftIO MVar.newEmptyMVar - sock <- liftIO $ socket AF_INET Stream 0 - liftIO $ setSocketOption sock ReuseAddr 1 - -- bind sock (SockAddrInet 4242 iNADDR_ANY) - -- let portNumber = read (show port) :: PortNumber - -- liftIO $ bind sock (SockAddrInet portNumber 0x0100007f) -- Yay terrible hacks to get code that should be simple working, what a day to be alive - let hints = defaultHints { - addrFlags = [AI_PASSIVE] - , addrSocketType = Stream - } - addrInfo <- liftIO $ getAddrInfo (Just hints) Nothing $ Just $ show port - - liftIO $ bind sock $ addrAddress $ head addrInfo - liftIO $ listen sock 2 + (mvar, chan) <- liftIO $ NS.createServer port liftIO $ C.traceIO "Server created" -- return $ VServerSocket mvar - return $ VServerSocket sock + return $ VServerSocket mvar chan _ -> throw $ NotAnExpectedValueException "VInt" val Accept e t -> do liftIO $ C.traceIO "Accepting new client!" - r <- liftIO Chan.newChan - w <- liftIO Chan.newChan val <- interpret' e case val of - VServerSocket socketRaw -> do + VServerSocket mvar chan -> do -- socket <- liftIO $ MVar.readMVar socketMVar - socket <- liftIO $ accept socketRaw - liftIO $ C.traceIO "Aquired socket" - handle <- liftIO $ NC.getHandle $ fst socket - liftIO $ forkIO $ NC.recieveMessages r handle - -- liftIO $ forkIO $ NC.communicate r w $ fst socket + newuser <- liftIO $ Chan.readChan chan + clientuser <- liftIO $ NC.getConnectionInfo mvar newuser liftIO $ C.traceIO "Client accepted" - return $ VChan r w (Just handle) (Just $ snd socket) Nothing Nothing + return $ VChan (readChannel clientuser) (writeChannel clientuser) (Just $ ProcessEnvironment.handle clientuser ) (Just $ addr clientuser ) (Just newuser) Nothing _ -> throw $ NotAnExpectedValueException "VServerSocket" val Connect e1 e2 t -> do @@ -229,7 +217,9 @@ eval = \case handle <- liftIO $ NC.getHandle clientsocket liftIO $ forkIO $ NC.recieveMessages r handle liftIO $ C.traceIO "Client connected" - return $ VChan r w (Just handle) (Just $ addrAddress $ head addrInfo) Nothing Nothing + ownuserid <- liftIO $ UserID.newRandomUserID + liftIO $ NC.sendMessage (Messages.Introduce ownuserid) handle + return $ VChan r w (Just handle) (Just $ addrAddress $ head addrInfo) Nothing $ Just ownuserid _ -> throw $ NotAnExpectedValueException "VInt" portVal _ -> throw $ NotAnExpectedValueException "VString" addressVal where diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index c4523d1..512fa0e 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -43,15 +43,24 @@ communicate read write socket = do recieveReadable read handle -} + +-- Hangs if no valid client id is provided +getConnectionInfo :: MVar.MVar (Map String ConnectionInfo) -> String -> IO ConnectionInfo +getConnectionInfo mvar user = do + dict <- MVar.readMVar mvar + case Map.lookup user dict of + Nothing -> getConnectionInfo mvar user + Just clientinfo -> return clientinfo + -- This waits until the handle is found -userIDToHandle :: MVar.MVar (Map.Map String Handle) -> String -> IO Handle +userIDToHandle :: MVar.MVar (Map.Map String ConnectionInfo) -> String -> IO Handle userIDToHandle mvar userid = do useridmap <- readMVar mvar case Map.lookup userid useridmap of - Just handle -> return handle + Just connectioninfo -> return $ handle connectioninfo Nothing -> userIDToHandle mvar userid -sendMessageID :: Value -> MVar.MVar (Map.Map String Handle) -> String -> IO () +sendMessageID :: Value -> MVar.MVar (Map.Map String ConnectionInfo) -> String -> IO () sendMessageID value handlemapmvar userid = do serializedValue <- NSerialize.serialize $ NewValue userid value putStrLn $ "Sending message:" ++ serializedValue @@ -65,7 +74,7 @@ sendMessageID value handlemapmvar userid = do Nothing -> putStrLn $ "Error " ++ userid ++ " not found while trying to recieve messages" -} -recieveMessagesID :: Chan.Chan Value -> MVar.MVar (Map.Map String Handle) -> String -> IO () +recieveMessagesID :: Chan.Chan Value -> MVar.MVar (Map.Map String ConnectionInfo) -> String -> IO () recieveMessagesID chan mvar userid = do handle <- userIDToHandle mvar userid message <- hGetLine handle @@ -86,13 +95,14 @@ recieveMessagesID chan mvar userid = do recieveMessagesID chan mvar userid -sendMessage :: Value -> Handle -> IO () +sendMessage :: NSerialize.Serializable a => a -> Handle -> IO () sendMessage value handle = do serializedValue <- NSerialize.serialize value putStrLn $ "Sending message:" ++ serializedValue hPutStrLn handle (serializedValue ++" ") + recieveMessages :: Chan.Chan Value -> Handle -> IO () recieveMessages chan handle = do message <- hGetLine handle diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index 1b7110e..cfd4bdf 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -53,7 +53,7 @@ instance Serializable Value where VRec env f x e0 e1 -> serializeLabeledEntryMulti "VRec" env $ sNext f $ sNext x $ sNext e0 $ sLast e1 VNewNatRec env f n tid ty ez x es -> serializeLabeledEntryMulti "VNewNatRec" env $ sNext f $ sNext n $ sNext tid $ sNext ty $ sNext ez $ sNext x $ sLast es - VServerSocket _ -> throw $ UnserializableException "VServerSocket" + VServerSocket {} -> throw $ UnserializableException "VServerSocket" VChan {} -> throw $ UnserializableException "VChan" instance Serializable Multiplicity where diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 6596f1b..b779953 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -14,6 +14,7 @@ import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG import qualified Networking.Common as NC import qualified Networking.Serialize as NSerialize +import ProcessEnvironment import Control.Exception @@ -27,7 +28,7 @@ instance Show ServerException where instance Exception ServerException -createServer :: Int -> IO (MVar.MVar (Map String Handle)) +createServer :: Int -> IO (MVar.MVar (Map String ConnectionInfo), Chan.Chan String) createServer port = do sock <- liftIO $ socket AF_INET Stream 0 liftIO $ setSocketOption sock ReuseAddr 1 @@ -41,20 +42,25 @@ createServer port = do liftIO $ listen sock 2 mvar <- MVar.newEmptyMVar MVar.putMVar mvar empty - return mvar + chan <- Chan.newChan + forkIO $ acceptClients mvar chan sock + return (mvar, chan) -acceptClients :: MVar.MVar (Map String (Handle, SockAddr)) -> Chan.Chan String -> Socket -> IO () +acceptClients :: MVar.MVar (Map String ConnectionInfo) -> Chan.Chan String -> Socket -> IO () acceptClients mvar chan socket = do clientsocket <- accept socket forkIO $ acceptClient mvar chan clientsocket acceptClients mvar chan socket -acceptClient :: MVar.MVar (Map String (Handle, SockAddr)) -> Chan.Chan String -> (Socket, SockAddr) -> IO () +acceptClient :: MVar.MVar (Map String ConnectionInfo) -> Chan.Chan String -> (Socket, SockAddr) -> IO () acceptClient mvar chan clientsocket = do hdl <- NC.getHandle $ fst clientsocket userid <- waitForIntroduction hdl - MVar.modifyMVar_ mvar (return . insert userid (hdl, snd clientsocket)) + r <- Chan.newChan + w <- Chan.newChan + MVar.modifyMVar_ mvar (return . insert userid (ConnectionInfo hdl (snd clientsocket) r w)) + forkIO $ NC.recieveMessagesID r mvar userid Chan.writeChan chan userid waitForIntroduction :: Handle -> IO String diff --git a/src/PrettySyntax.hs b/src/PrettySyntax.hs index 8bc25f8..7e62fc1 100644 --- a/src/PrettySyntax.hs +++ b/src/PrettySyntax.hs @@ -177,7 +177,7 @@ instance Pretty Value where VFuncCast v ft1 ft2 -> pretty "(" <+> pretty v <+> pretty " : " <+> pretty ft1 <+> pretty " ⇒ " <+> pretty ft2 <+> pretty ")" VRec {} -> pretty "VRec" VNewNatRec {} -> pretty "VNewNatRec" - VServerSocket s -> pretty "VServerSocket" + VServerSocket _ _-> pretty "VServerSocket" instance Pretty FuncType where pretty (FuncType _ s t1 t2) = pretty "Π(" <+> pretty s <+> pretty ":" <+> pretty t1 <+> pretty ")" <+> pretty t2 diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index e11d99b..256b2bb 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -7,10 +7,12 @@ import Control.Concurrent.Chan as C import Control.Concurrent.MVar as MVar import Control.Monad.Reader as T import Data.Set (Set) +import Data.Map as Map import qualified Data.Set as Set import Kinds (Multiplicity(..)) import Network.Socket +-- import qualified Networking.Common as NC -- | the interpretation monad type InterpretM a = T.ReaderT PEnv IO a @@ -58,9 +60,12 @@ data Value | VRec PEnv String String Exp Exp | VNewNatRec PEnv String String String Type Exp String Exp -- | VServerSocket (MVar.MVar Socket) - | VServerSocket Socket + -- | VServerSocket Socket + | VServerSocket (MVar.MVar (Map.Map String ConnectionInfo)) (C.Chan String) deriving Eq +data ConnectionInfo = ConnectionInfo {handle :: Handle, addr :: SockAddr, readChannel :: C.Chan Value, writeChannel :: C.Chan Value} + instance Show Value where show = \case VUnit -> "VUnit" @@ -77,7 +82,7 @@ instance Show Value where VFuncCast v ft1 ft2 -> "VFuncCast (" ++ show v ++ ") (" ++ show ft1 ++ ") (" ++ show ft2 ++ ")" VRec env f x e1 e0 -> "VRec " ++ " " ++ f ++ " " ++ x ++ " " ++ show e1 ++ " " ++ show e0 VNewNatRec env f n tid ty ez x es -> "VNewNatRec " ++ f ++ n ++ tid ++ show ty ++ show ez ++ x ++ show es - VServerSocket _ -> "VServerSocket" + VServerSocket _ _-> "VServerSocket" class Subtypeable t where isSubtypeOf :: t -> t -> Bool From 81c4b7648573a8a43c3c1aa24bb4a6355cd33023 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 1 Dec 2022 18:25:16 +0100 Subject: [PATCH 026/229] Server and client now introduce themselves --- src/Interpreter.hs | 17 +++++++++++------ src/Networking/Common.hs | 29 +++++++++++++++++++++++++++- src/Networking/Server.hs | 40 ++++++++++++++++++++++----------------- src/PrettySyntax.hs | 2 +- src/ProcessEnvironment.hs | 5 +++-- 5 files changed, 66 insertions(+), 27 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 2d85e1a..a0c052f 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -171,10 +171,10 @@ eval = \case case val of VInt port -> do -- mvar <- liftIO MVar.newEmptyMVar - (mvar, chan) <- liftIO $ NS.createServer port + (mvar, chan, serverid) <- liftIO $ NS.createServer port liftIO $ C.traceIO "Server created" -- return $ VServerSocket mvar - return $ VServerSocket mvar chan + return $ VServerSocket mvar chan serverid _ -> throw $ NotAnExpectedValueException "VInt" val Accept e t -> do @@ -182,12 +182,12 @@ eval = \case val <- interpret' e case val of - VServerSocket mvar chan -> do + VServerSocket mvar chan serverid -> do -- socket <- liftIO $ MVar.readMVar socketMVar newuser <- liftIO $ Chan.readChan chan clientuser <- liftIO $ NC.getConnectionInfo mvar newuser liftIO $ C.traceIO "Client accepted" - return $ VChan (readChannel clientuser) (writeChannel clientuser) (Just $ ProcessEnvironment.handle clientuser ) (Just $ addr clientuser ) (Just newuser) Nothing + return $ VChan (readChannel clientuser) (writeChannel clientuser) (Just $ ProcessEnvironment.handle clientuser ) (Just $ addr clientuser ) (Just newuser) $ Just serverid _ -> throw $ NotAnExpectedValueException "VServerSocket" val Connect e1 e2 t -> do @@ -215,11 +215,16 @@ eval = \case liftIO $ connect clientsocket $ addrAddress $ head addrInfo -- liftIO $ forkIO $ NC.communicate r w clientsocket handle <- liftIO $ NC.getHandle clientsocket - liftIO $ forkIO $ NC.recieveMessages r handle liftIO $ C.traceIO "Client connected" ownuserid <- liftIO $ UserID.newRandomUserID liftIO $ NC.sendMessage (Messages.Introduce ownuserid) handle - return $ VChan r w (Just handle) (Just $ addrAddress $ head addrInfo) Nothing $ Just ownuserid + + -- Wait for answer from the server + serverid <- liftIO $ NC.waitForServerIntroduction handle + + -- Hockup automatic message recieving + liftIO $ forkIO $ NC.recieveMessages r handle + return $ VChan r w (Just handle) (Just $ addrAddress $ head addrInfo) (Just serverid) $ Just ownuserid _ -> throw $ NotAnExpectedValueException "VInt" portVal _ -> throw $ NotAnExpectedValueException "VString" addressVal where diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 512fa0e..9b5ca8d 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + module Networking.Common where import qualified Control.Exception as E @@ -16,6 +18,7 @@ import ProcessEnvironment import qualified Networking.Serialize as NSerialize import Networking.Messages +import Control.Exception import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG @@ -44,6 +47,16 @@ communicate read write socket = do -} +newtype ServerException = NoIntroductionException String + deriving Eq + +instance Show ServerException where + show = \case + NoIntroductionException s -> "Partner didn't introduce itself, but sent: " ++ s + +instance Exception ServerException + + -- Hangs if no valid client id is provided getConnectionInfo :: MVar.MVar (Map String ConnectionInfo) -> String -> IO ConnectionInfo getConnectionInfo mvar user = do @@ -57,7 +70,7 @@ userIDToHandle :: MVar.MVar (Map.Map String ConnectionInfo) -> String -> IO Hand userIDToHandle mvar userid = do useridmap <- readMVar mvar case Map.lookup userid useridmap of - Just connectioninfo -> return $ handle connectioninfo + Just connectioninfo -> return $ ProcessEnvironment.handle connectioninfo Nothing -> userIDToHandle mvar userid sendMessageID :: Value -> MVar.MVar (Map.Map String ConnectionInfo) -> String -> IO () @@ -125,3 +138,17 @@ getSocket mvar socket = do putStrLn "Trying to send socket" MVar.putMVar mvar socket putStrLn "Sent socket" + +waitForServerIntroduction :: Handle -> IO String +waitForServerIntroduction handle = do + message <- hGetLine handle + case VT.runAlex message VG.parseMessages of + Left err -> do + putStrLn $ "Error during server introduction: "++err + throw $ NoIntroductionException message + Right deserial -> case deserial of + Introduce partner -> do + return partner + _ -> do + putStrLn $ "Error during server introduction, wrong message: "++ message + throw $ NoIntroductionException message diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index b779953..df7b474 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -14,22 +14,26 @@ import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG import qualified Networking.Common as NC import qualified Networking.Serialize as NSerialize +import qualified Networking.UserID as UserID import ProcessEnvironment import Control.Exception +import qualified Networking.UserID as UserID +import qualified Networking.Messages as Messages -newtype ServerException = NoIntroductionException String +{-newtype ServerException = NoIntroductionException String deriving Eq instance Show ServerException where show = \case NoIntroductionException s -> "Client didn't introduce itself, but sent: " ++ s -instance Exception ServerException +instance Exception ServerException-} -createServer :: Int -> IO (MVar.MVar (Map String ConnectionInfo), Chan.Chan String) +createServer :: Int -> IO (MVar.MVar (Map String ConnectionInfo), Chan.Chan String, String) createServer port = do + serverid <- UserID.newRandomUserID sock <- liftIO $ socket AF_INET Stream 0 liftIO $ setSocketOption sock ReuseAddr 1 let hints = defaultHints { @@ -43,35 +47,37 @@ createServer port = do mvar <- MVar.newEmptyMVar MVar.putMVar mvar empty chan <- Chan.newChan - forkIO $ acceptClients mvar chan sock - return (mvar, chan) + forkIO $ acceptClients mvar chan sock serverid + return (mvar, chan, serverid) -acceptClients :: MVar.MVar (Map String ConnectionInfo) -> Chan.Chan String -> Socket -> IO () -acceptClients mvar chan socket = do +acceptClients :: MVar.MVar (Map String ConnectionInfo) -> Chan.Chan String -> Socket -> String-> IO () +acceptClients mvar chan socket serverid = do clientsocket <- accept socket - forkIO $ acceptClient mvar chan clientsocket - acceptClients mvar chan socket + forkIO $ acceptClient mvar chan clientsocket serverid + acceptClients mvar chan socket serverid -acceptClient :: MVar.MVar (Map String ConnectionInfo) -> Chan.Chan String -> (Socket, SockAddr) -> IO () -acceptClient mvar chan clientsocket = do +acceptClient :: MVar.MVar (Map String ConnectionInfo) -> Chan.Chan String -> (Socket, SockAddr) -> String -> IO () +acceptClient mvar chan clientsocket serverid = do hdl <- NC.getHandle $ fst clientsocket - userid <- waitForIntroduction hdl + userid <- waitForIntroduction hdl serverid r <- Chan.newChan w <- Chan.newChan MVar.modifyMVar_ mvar (return . insert userid (ConnectionInfo hdl (snd clientsocket) r w)) forkIO $ NC.recieveMessagesID r mvar userid Chan.writeChan chan userid -waitForIntroduction :: Handle -> IO String -waitForIntroduction handle = do +waitForIntroduction :: Handle -> String -> IO String +waitForIntroduction handle serverid = do message <- hGetLine handle case VT.runAlex message VG.parseMessages of Left err -> do putStrLn $ "Error during client introduction: "++err - throw $ NoIntroductionException message + throw $ NC.NoIntroductionException message Right deserial -> case deserial of - Introduce partner -> return partner + Introduce partner -> do + NC.sendMessage (Messages.Introduce serverid) handle + return partner _ -> do putStrLn $ "Error during client introduction, wrong message: "++ message - throw $ NoIntroductionException message \ No newline at end of file + throw $ NC.NoIntroductionException message \ No newline at end of file diff --git a/src/PrettySyntax.hs b/src/PrettySyntax.hs index 7e62fc1..77415d1 100644 --- a/src/PrettySyntax.hs +++ b/src/PrettySyntax.hs @@ -177,7 +177,7 @@ instance Pretty Value where VFuncCast v ft1 ft2 -> pretty "(" <+> pretty v <+> pretty " : " <+> pretty ft1 <+> pretty " ⇒ " <+> pretty ft2 <+> pretty ")" VRec {} -> pretty "VRec" VNewNatRec {} -> pretty "VNewNatRec" - VServerSocket _ _-> pretty "VServerSocket" + VServerSocket {}-> pretty "VServerSocket" instance Pretty FuncType where pretty (FuncType _ s t1 t2) = pretty "Π(" <+> pretty s <+> pretty ":" <+> pretty t1 <+> pretty ")" <+> pretty t2 diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index 256b2bb..5002de1 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -61,7 +61,8 @@ data Value | VNewNatRec PEnv String String String Type Exp String Exp -- | VServerSocket (MVar.MVar Socket) -- | VServerSocket Socket - | VServerSocket (MVar.MVar (Map.Map String ConnectionInfo)) (C.Chan String) + | VServerSocket (MVar.MVar (Map.Map String ConnectionInfo)) (C.Chan String) String + -- This is the server id deriving Eq data ConnectionInfo = ConnectionInfo {handle :: Handle, addr :: SockAddr, readChannel :: C.Chan Value, writeChannel :: C.Chan Value} @@ -82,7 +83,7 @@ instance Show Value where VFuncCast v ft1 ft2 -> "VFuncCast (" ++ show v ++ ") (" ++ show ft1 ++ ") (" ++ show ft2 ++ ")" VRec env f x e1 e0 -> "VRec " ++ " " ++ f ++ " " ++ x ++ " " ++ show e1 ++ " " ++ show e0 VNewNatRec env f n tid ty ez x es -> "VNewNatRec " ++ f ++ n ++ tid ++ show ty ++ show ez ++ x ++ show es - VServerSocket _ _-> "VServerSocket" + VServerSocket {} -> "VServerSocket" class Subtypeable t where isSubtypeOf :: t -> t -> Bool From 09cb7e02e29fefb49c344a20a6f4e39964fe0ae6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Fri, 2 Dec 2022 16:47:16 +0100 Subject: [PATCH 027/229] Update Interpreter.hs --- src/Interpreter.hs | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index a0c052f..10a802f 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -18,6 +18,7 @@ import Network.Socket import Control.Concurrent (forkIO) import Data.Foldable (find) import Data.Maybe (fromJust) +import qualified Data.Map as Map import ProcessEnvironment import qualified Control.Monad as M import Control.Monad.Reader as R @@ -169,7 +170,7 @@ eval = \case val <- interpret' e case val of - VInt port -> do + VInt port -> do -- mvar <- liftIO MVar.newEmptyMVar (mvar, chan, serverid) <- liftIO $ NS.createServer port liftIO $ C.traceIO "Server created" @@ -182,7 +183,7 @@ eval = \case val <- interpret' e case val of - VServerSocket mvar chan serverid -> do + VServerSocket mvar chan serverid -> do -- socket <- liftIO $ MVar.readMVar socketMVar newuser <- liftIO $ Chan.readChan chan clientuser <- liftIO $ NC.getConnectionInfo mvar newuser @@ -197,7 +198,7 @@ eval = \case addressVal <- interpret' e1 case addressVal of - VString address -> do + VString address -> do portVal <- interpret' e2 case portVal of VInt port -> do @@ -211,19 +212,23 @@ eval = \case , addrSocketType = Stream } addrInfo <- liftIO $ getAddrInfo (Just hints) (Just address) $ Just $ show port - clientsocket <- liftIO $ openSocket $ head addrInfo + clientsocket <- liftIO $ openSocket $ head addrInfo liftIO $ connect clientsocket $ addrAddress $ head addrInfo -- liftIO $ forkIO $ NC.communicate r w clientsocket handle <- liftIO $ NC.getHandle clientsocket liftIO $ C.traceIO "Client connected" - ownuserid <- liftIO $ UserID.newRandomUserID - liftIO $ NC.sendMessage (Messages.Introduce ownuserid) handle + ownuserid <- liftIO UserID.newRandomUserID + liftIO $ NC.sendMessage (Messages.Introduce ownuserid) handle -- Wait for answer from the server serverid <- liftIO $ NC.waitForServerIntroduction handle -- Hockup automatic message recieving - liftIO $ forkIO $ NC.recieveMessages r handle + mvar <- liftIO MVar.newEmptyMVar + liftIO $ MVar.putMVar mvar (Map.fromList [(serverid, ConnectionInfo handle (addrAddress $ head addrInfo) r w )]) + liftIO $ forkIO $ NC.recieveMessagesID r mvar serverid + + return $ VChan r w (Just handle) (Just $ addrAddress $ head addrInfo) (Just serverid) $ Just ownuserid _ -> throw $ NotAnExpectedValueException "VInt" portVal _ -> throw $ NotAnExpectedValueException "VString" addressVal @@ -262,7 +267,7 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) | n > 0 = do let env' = extendEnv n1 (VInt (n-1)) (extendEnv f natrec env) R.local (const env') (interpret' es) -interpretApp _ (VSend v@(VChan _ c handle _ _ _)) w = do +interpretApp _ (VSend v@(VChan _ c handle _ _ _)) w = do liftIO (Chan.writeChan c w) case handle of Nothing -> pure () From b2de19448c845ef5a612b601aec470daae1890e5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Fri, 2 Dec 2022 17:23:46 +0100 Subject: [PATCH 028/229] Small name refactor --- src/Interpreter.hs | 2 +- src/Networking/Common.hs | 2 +- src/ProcessEnvironment.hs | 4 +++- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 10a802f..b613999 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -188,7 +188,7 @@ eval = \case newuser <- liftIO $ Chan.readChan chan clientuser <- liftIO $ NC.getConnectionInfo mvar newuser liftIO $ C.traceIO "Client accepted" - return $ VChan (readChannel clientuser) (writeChannel clientuser) (Just $ ProcessEnvironment.handle clientuser ) (Just $ addr clientuser ) (Just newuser) $ Just serverid + return $ VChan (ciReadChannel clientuser) (ciWriteChannel clientuser) (Just $ ciHandle clientuser ) (Just $ ciAddr clientuser ) (Just newuser) $ Just serverid _ -> throw $ NotAnExpectedValueException "VServerSocket" val Connect e1 e2 t -> do diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 9b5ca8d..684d5a9 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -70,7 +70,7 @@ userIDToHandle :: MVar.MVar (Map.Map String ConnectionInfo) -> String -> IO Hand userIDToHandle mvar userid = do useridmap <- readMVar mvar case Map.lookup userid useridmap of - Just connectioninfo -> return $ ProcessEnvironment.handle connectioninfo + Just connectioninfo -> return $ ciHandle connectioninfo Nothing -> userIDToHandle mvar userid sendMessageID :: Value -> MVar.MVar (Map.Map String ConnectionInfo) -> String -> IO () diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index 5002de1..4418a98 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -65,7 +65,9 @@ data Value -- This is the server id deriving Eq -data ConnectionInfo = ConnectionInfo {handle :: Handle, addr :: SockAddr, readChannel :: C.Chan Value, writeChannel :: C.Chan Value} +data ConnectionInfo = ConnectionInfo {ciHandle :: Handle, ciAddr :: SockAddr, ciReadChannel :: C.Chan Value, ciWriteChannel :: C.Chan Value} + +--data CommunicationChannel = CommunicationChannel {} instance Show Value where show = \case From 982a0ee5fd12d6ddea74413437277c7f4fe9b516 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Fri, 2 Dec 2022 19:12:39 +0100 Subject: [PATCH 029/229] Update ProcessEnvironment.hs --- src/ProcessEnvironment.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index 4418a98..59a8323 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -11,6 +11,8 @@ import Data.Map as Map import qualified Data.Set as Set import Kinds (Multiplicity(..)) +import Networking.DirectionalConnection + import Network.Socket -- import qualified Networking.Common as NC @@ -67,7 +69,11 @@ data Value data ConnectionInfo = ConnectionInfo {ciHandle :: Handle, ciAddr :: SockAddr, ciReadChannel :: C.Chan Value, ciWriteChannel :: C.Chan Value} ---data CommunicationChannel = CommunicationChannel {} +data CommunicationChannel = CommunicationChannel {ccRead :: DirectionalConnection Value, ccWrite :: DirectionalConnection Value, ccPartnerUserID :: Maybe String, ccOwnUserID :: Maybe String, ccPartnerAddress :: Maybe SockAddr, ccChannelState :: ChannelState} + +data ChannelState = Connected {csConInfoMap :: MVar.MVar (Map.Map String ConnectionInfo)} + | Disconnected + instance Show Value where show = \case From 6c47f6a245dc29666df41f214998fbbe8e2b1e84 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sat, 3 Dec 2022 15:18:40 +0100 Subject: [PATCH 030/229] Switched from Channels to CommunicationChannels --- src/Interpreter.hs | 54 ++++++++++++++++++------- src/Networking/Common.hs | 17 +++++--- src/Networking/DirectionalConnection.hs | 2 +- src/Networking/Server.hs | 5 ++- src/ProcessEnvironment.hs | 14 +++++-- 5 files changed, 66 insertions(+), 26 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index b613999..f2a7247 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -40,6 +40,9 @@ import Control.Concurrent import qualified Networking.UserID as UserID import qualified Networking.Messages as Messages +import qualified Networking.DirectionalConnection as DC +import ProcessEnvironment (CommunicationChannel(CommunicationChannel, ccChannelState, ccPartnerUserID), ConnectionInfo (ciReadChannel, ciWriteChannel)) +import qualified Control.Concurrent as MVar data InterpreterException = MathException String @@ -155,13 +158,23 @@ eval = \case C.traceIO "Ran a forked operation") return VUnit New t -> do - r <- liftIO Chan.newChan - w <- liftIO Chan.newChan - return $ VPair (VChan r w Nothing Nothing Nothing Nothing) (VChan w r Nothing Nothing Nothing Nothing) + -- r <- liftIO Chan.newChan + -- w <- liftIO Chan.newChan + -- return $ VPair (VChan r w Nothing Nothing Nothing Nothing) (VChan w r Nothing Nothing Nothing Nothing) + r <- liftIO DC.newConnection + w <- liftIO DC.newConnection + channelstate1 <- liftIO MVar.newEmptyMVar + liftIO $ MVar.putMVar channelstate1 Emulated + channelstate2 <- liftIO MVar.newEmptyMVar + liftIO $ MVar.putMVar channelstate2 Emulated + return $ VPair (VChan (CommunicationChannel r w Nothing Nothing Nothing channelstate1)) (VChan (CommunicationChannel w r Nothing Nothing Nothing channelstate2)) Send e -> VSend <$> interpret' e -- Apply VSend to the output of interpret' e Recv e -> do - interpret' e >>= \v@(VChan c _ _ _ _ _) -> do - val <- liftIO $ Chan.readChan c + interpret' e >>= \v@(VChan ci) -> do + let dcRead = ccRead ci + + -- val <- liftIO $ Chan.readChan c + val <- liftIO $ DC.readUnreadMessage dcRead liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e return $ VPair val v Case e cases -> interpret' e >>= \(VLabel s) -> interpret' $ fromJust $ lookup s cases @@ -188,12 +201,15 @@ eval = \case newuser <- liftIO $ Chan.readChan chan clientuser <- liftIO $ NC.getConnectionInfo mvar newuser liftIO $ C.traceIO "Client accepted" - return $ VChan (ciReadChannel clientuser) (ciWriteChannel clientuser) (Just $ ciHandle clientuser ) (Just $ ciAddr clientuser ) (Just newuser) $ Just serverid + -- return $ VChan (ciReadChannel clientuser) (ciWriteChannel clientuser) (Just $ ciHandle clientuser ) (Just $ ciAddr clientuser ) (Just newuser) $ Just serverid + channelstate <- liftIO MVar.newEmptyMVar + liftIO $ MVar.putMVar channelstate $ Connected mvar + return $ VChan $ CommunicationChannel (ciReadChannel clientuser) (ciWriteChannel clientuser) (Just newuser) (Just serverid) (Just $ ciAddr clientuser ) channelstate _ -> throw $ NotAnExpectedValueException "VServerSocket" val Connect e1 e2 t -> do - r <- liftIO Chan.newChan - w <- liftIO Chan.newChan + r <- liftIO DC.newConnection + w <- liftIO DC.newConnection liftIO $ C.traceIO "Client trying to connect" addressVal <- interpret' e1 @@ -229,7 +245,11 @@ eval = \case liftIO $ forkIO $ NC.recieveMessagesID r mvar serverid - return $ VChan r w (Just handle) (Just $ addrAddress $ head addrInfo) (Just serverid) $ Just ownuserid + -- return $ VChan r w (Just handle) (Just $ addrAddress $ head addrInfo) (Just serverid) $ Just ownuserid + channelstate <- liftIO MVar.newEmptyMVar + liftIO $ MVar.putMVar channelstate $ Connected mvar + + return $ VChan $ CommunicationChannel r w (Just serverid) (Just ownuserid) (Just $ addrAddress $ head addrInfo) channelstate _ -> throw $ NotAnExpectedValueException "VInt" portVal _ -> throw $ NotAnExpectedValueException "VString" addressVal where @@ -267,11 +287,17 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) | n > 0 = do let env' = extendEnv n1 (VInt (n-1)) (extendEnv f natrec env) R.local (const env') (interpret' es) -interpretApp _ (VSend v@(VChan _ c handle _ _ _)) w = do - liftIO (Chan.writeChan c w) - case handle of - Nothing -> pure () - Just hdl -> liftIO $ NC.sendMessage w hdl +-- interpretApp _ (VSend v@(VChan _ c handle _ _ _)) w = do +interpretApp _ (VSend v@(VChan cc)) w = do + -- liftIO (Chan.writeChan c w) + liftIO $ DC.writeMessage (ccWrite cc) w + channelstate <- liftIO $ MVar.readMVar (ccChannelState cc) + case ccPartnerUserID cc of + Just userid -> liftIO $ NC.sendMessageID w (csConInfoMap channelstate) userid + Nothing -> pure () + --case handle of + -- Nothing -> pure () + -- Just hdl -> liftIO $ NC.sendMessage w hdl return v interpretApp e _ _ = throw $ ApplicationException e diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 684d5a9..11b869b 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -22,6 +22,8 @@ import Control.Exception import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG +import qualified Networking.DirectionalConnection as DC +import Networking.DirectionalConnection (DirectionalConnection) {- -- communicate :: Chan.Chan Value -> Chan.Chan Value -> Socket -> IO () @@ -87,14 +89,19 @@ sendMessageID value handlemapmvar userid = do Nothing -> putStrLn $ "Error " ++ userid ++ " not found while trying to recieve messages" -} -recieveMessagesID :: Chan.Chan Value -> MVar.MVar (Map.Map String ConnectionInfo) -> String -> IO () +recieveMessagesID :: DirectionalConnection Value -> MVar.MVar (Map.Map String ConnectionInfo) -> String -> IO () recieveMessagesID chan mvar userid = do handle <- userIDToHandle mvar userid message <- hGetLine handle putStrLn $ "Recieved message:" ++ message - case VT.runAlex message VG.parseValues of + case VT.runAlex message VG.parseMessages of + -- case VT.runAlex message VG.parseValues of Left err -> putStrLn $ "Error during recieving a networkmessage: "++err - Right deserial -> writeChan chan deserial + Right deserialmessages -> case deserialmessages of + NewValue userid val -> DC.writeMessage chan val + _ -> do + serial <- NSerialize.serialize deserialmessages + putStrLn $ "Error unsupported networkmessage: "++ serial {- case maybehandle of Just handle -> do @@ -115,7 +122,7 @@ sendMessage value handle = do hPutStrLn handle (serializedValue ++" ") - +{- recieveMessages :: Chan.Chan Value -> Handle -> IO () recieveMessages chan handle = do message <- hGetLine handle @@ -124,7 +131,7 @@ recieveMessages chan handle = do Left err -> putStrLn $ "Error during recieving a networkmessage: "++err Right deserial -> writeChan chan deserial recieveMessages chan handle - +-} getHandle :: Socket -> IO Handle getHandle socket = do diff --git a/src/Networking/DirectionalConnection.hs b/src/Networking/DirectionalConnection.hs index 478cf07..a0e3441 100644 --- a/src/Networking/DirectionalConnection.hs +++ b/src/Networking/DirectionalConnection.hs @@ -1,4 +1,4 @@ -module Networking.DirectionalConnection (DirectionalConnection(..)) where +module Networking.DirectionalConnection (DirectionalConnection(..), newConnection, writeMessage, allMessages, readUnreadMessage) where import Control.Concurrent.Chan import Control.Concurrent.MVar diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index df7b474..5d73b78 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -20,6 +20,7 @@ import ProcessEnvironment import Control.Exception import qualified Networking.UserID as UserID import qualified Networking.Messages as Messages +import qualified Networking.DirectionalConnection as NC {-newtype ServerException = NoIntroductionException String deriving Eq @@ -61,8 +62,8 @@ acceptClient :: MVar.MVar (Map String ConnectionInfo) -> Chan.Chan String -> (So acceptClient mvar chan clientsocket serverid = do hdl <- NC.getHandle $ fst clientsocket userid <- waitForIntroduction hdl serverid - r <- Chan.newChan - w <- Chan.newChan + r <- NC.newConnection + w <- NC.newConnection MVar.modifyMVar_ mvar (return . insert userid (ConnectionInfo hdl (snd clientsocket) r w)) forkIO $ NC.recieveMessagesID r mvar userid Chan.writeChan chan userid diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index 59a8323..2c7bace 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -50,7 +50,8 @@ data Value | VString String -- we have two channels, one for reading and one for writing to the other -- end, so we do not read our own written values - | VChan (C.Chan Value) (C.Chan Value) (Maybe Handle) (Maybe SockAddr) (Maybe String) (Maybe String) + -- | VChan (C.Chan Value) (C.Chan Value) (Maybe Handle) (Maybe SockAddr) (Maybe String) (Maybe String) + | VChan CommunicationChannel -- Read Chan Write Chan Handle of Con Address of other other Userid own UserID -- | VChan (C.Chan Value) (C.Chan Value) | VSend Value @@ -67,13 +68,18 @@ data Value -- This is the server id deriving Eq -data ConnectionInfo = ConnectionInfo {ciHandle :: Handle, ciAddr :: SockAddr, ciReadChannel :: C.Chan Value, ciWriteChannel :: C.Chan Value} +data ConnectionInfo = ConnectionInfo {ciHandle :: Handle, ciAddr :: SockAddr, ciReadChannel :: DirectionalConnection Value, ciWriteChannel :: DirectionalConnection Value} + deriving Eq -data CommunicationChannel = CommunicationChannel {ccRead :: DirectionalConnection Value, ccWrite :: DirectionalConnection Value, ccPartnerUserID :: Maybe String, ccOwnUserID :: Maybe String, ccPartnerAddress :: Maybe SockAddr, ccChannelState :: ChannelState} +data CommunicationChannel = CommunicationChannel {ccRead :: DirectionalConnection Value, ccWrite :: DirectionalConnection Value, ccPartnerUserID :: Maybe String, ccOwnUserID :: Maybe String, ccPartnerAddress :: Maybe SockAddr, ccChannelState :: MVar.MVar ChannelState} + deriving Eq + -- Change this to Maybe MVar SockAddr data ChannelState = Connected {csConInfoMap :: MVar.MVar (Map.Map String ConnectionInfo)} | Disconnected - + | Emulated + | Disabled -- Used when a Channel was sent --> Maybe we can automatically change this on serialization when we put this in a MVar + deriving Eq instance Show Value where show = \case From 2efc786c9e3b98b239469b3e39f3a1df94a15918 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sat, 3 Dec 2022 15:41:53 +0100 Subject: [PATCH 031/229] Added examplecode for chan handoff --- dev-examples/handoff/client.ldgvnw | 27 ++++++++++++++++++++ dev-examples/handoff/handoff.ldgvnw | 27 ++++++++++++++++++++ dev-examples/{ => handoff}/server.ldgvnw | 0 dev-examples/{ => simple}/client.ldgvnw | 0 dev-examples/{ => simple}/server copy.ldgvnw | 0 dev-examples/simple/server.ldgvnw | 20 +++++++++++++++ 6 files changed, 74 insertions(+) create mode 100644 dev-examples/handoff/client.ldgvnw create mode 100644 dev-examples/handoff/handoff.ldgvnw rename dev-examples/{ => handoff}/server.ldgvnw (100%) rename dev-examples/{ => simple}/client.ldgvnw (100%) rename dev-examples/{ => simple}/server copy.ldgvnw (100%) create mode 100644 dev-examples/simple/server.ldgvnw diff --git a/dev-examples/handoff/client.ldgvnw b/dev-examples/handoff/client.ldgvnw new file mode 100644 index 0000000..afcf974 --- /dev/null +++ b/dev-examples/handoff/client.ldgvnw @@ -0,0 +1,27 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendTwoInt : ! ~ssn = !Int. !Int. Unit +type SendOneInt : ! ~ssn = !Int. Unit +type SendSendOneInt : ! ~ssn = !SendOneInt. Unit + +val send1 (c: SendTwoInt) : SendOneInt = + let x = ((send c) 1) in + (x) + +val send2 (c2: SendOneInt) = + let y = ((send c2) 42) in + () + +val add2 (c1: dualof SendTwoInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val main : Unit +val main = + let con = (connect "127.0.0.1" 4242 SendTwoInt) in -- This cannot be localhost, since this might break on containerized images + let oneint = send1 con in + let con2 = (connect "127.0.0.1" 4343 SendSendOneInt) in + (send con2) oneint + diff --git a/dev-examples/handoff/handoff.ldgvnw b/dev-examples/handoff/handoff.ldgvnw new file mode 100644 index 0000000..75676a9 --- /dev/null +++ b/dev-examples/handoff/handoff.ldgvnw @@ -0,0 +1,27 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendTwoInt : ! ~ssn = !Int. !Int. Unit +type SendOneInt : ! ~ssn = !Int. Unit +type SendSendOneInt : ! ~ssn = !SendOneInt. Unit + +val send1 (c: SendTwoInt) : SendOneInt = + let x = ((send c) 1) in + (x) + +val send2 (c2: SendOneInt) = + let y = ((send c2) 42) in + () + +val add2 (c1: dualof SendTwoInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val main : Unit +val main = + let con = (create 4343) in + let sock = (accept con (dualof SendSendOneInt)) in + let = recv sock in + send2 oneint + diff --git a/dev-examples/server.ldgvnw b/dev-examples/handoff/server.ldgvnw similarity index 100% rename from dev-examples/server.ldgvnw rename to dev-examples/handoff/server.ldgvnw diff --git a/dev-examples/client.ldgvnw b/dev-examples/simple/client.ldgvnw similarity index 100% rename from dev-examples/client.ldgvnw rename to dev-examples/simple/client.ldgvnw diff --git a/dev-examples/server copy.ldgvnw b/dev-examples/simple/server copy.ldgvnw similarity index 100% rename from dev-examples/server copy.ldgvnw rename to dev-examples/simple/server copy.ldgvnw diff --git a/dev-examples/simple/server.ldgvnw b/dev-examples/simple/server.ldgvnw new file mode 100644 index 0000000..56004ce --- /dev/null +++ b/dev-examples/simple/server.ldgvnw @@ -0,0 +1,20 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let y = ((send x) 42) in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val main : Int +val main = + let con = (create 4242) in + let sock = (accept con (dualof SendInt)) in + add2 sock From 7d3d1d65cead1b7e07c956a1d3fe51b5ce8c947d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sat, 3 Dec 2022 17:43:38 +0100 Subject: [PATCH 032/229] Work towards sending VChans --- src/Interpreter.hs | 6 ++-- src/Networking/Serialize.hs | 60 +++++++++++++++++++++++++++++-------- src/ProcessEnvironment.hs | 3 +- 3 files changed, 53 insertions(+), 16 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index f2a7247..868b443 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -167,7 +167,7 @@ eval = \case liftIO $ MVar.putMVar channelstate1 Emulated channelstate2 <- liftIO MVar.newEmptyMVar liftIO $ MVar.putMVar channelstate2 Emulated - return $ VPair (VChan (CommunicationChannel r w Nothing Nothing Nothing channelstate1)) (VChan (CommunicationChannel w r Nothing Nothing Nothing channelstate2)) + return $ VPair (VChan (CommunicationChannel r w Nothing Nothing channelstate1)) (VChan (CommunicationChannel w r Nothing Nothing channelstate2)) Send e -> VSend <$> interpret' e -- Apply VSend to the output of interpret' e Recv e -> do interpret' e >>= \v@(VChan ci) -> do @@ -204,7 +204,7 @@ eval = \case -- return $ VChan (ciReadChannel clientuser) (ciWriteChannel clientuser) (Just $ ciHandle clientuser ) (Just $ ciAddr clientuser ) (Just newuser) $ Just serverid channelstate <- liftIO MVar.newEmptyMVar liftIO $ MVar.putMVar channelstate $ Connected mvar - return $ VChan $ CommunicationChannel (ciReadChannel clientuser) (ciWriteChannel clientuser) (Just newuser) (Just serverid) (Just $ ciAddr clientuser ) channelstate + return $ VChan $ CommunicationChannel (ciReadChannel clientuser) (ciWriteChannel clientuser) (Just newuser) (Just serverid) channelstate _ -> throw $ NotAnExpectedValueException "VServerSocket" val Connect e1 e2 t -> do @@ -249,7 +249,7 @@ eval = \case channelstate <- liftIO MVar.newEmptyMVar liftIO $ MVar.putMVar channelstate $ Connected mvar - return $ VChan $ CommunicationChannel r w (Just serverid) (Just ownuserid) (Just $ addrAddress $ head addrInfo) channelstate + return $ VChan $ CommunicationChannel r w (Just serverid) (Just ownuserid) channelstate _ -> throw $ NotAnExpectedValueException "VInt" portVal _ -> throw $ NotAnExpectedValueException "VString" addressVal where diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index cfd4bdf..032507f 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -5,6 +5,7 @@ module Networking.Serialize where import Control.Monad.IO.Class import Control.Concurrent.Chan as Chan +import qualified Control.Concurrent.MVar as MVar import Syntax import Kinds import qualified Syntax as S @@ -14,6 +15,11 @@ import Control.Concurrent (getChanContents) import Control.Exception import ProcessEnvironment import Networking.Messages +import qualified Networking.DirectionalConnection as DC +import qualified Networking.DirectionalConnection as DC +import qualified Data.Maybe +import qualified Data.Map as Map +import qualified Network.Socket as Sock newtype SerializationException = UnserializableException String @@ -52,9 +58,39 @@ instance Serializable Value where VFuncCast v ft1 ft2 -> serializeLabeledEntryMulti "VFuncCast" v $ sNext ft1 $ sLast ft2 VRec env f x e0 e1 -> serializeLabeledEntryMulti "VRec" env $ sNext f $ sNext x $ sNext e0 $ sLast e1 VNewNatRec env f n tid ty ez x es -> serializeLabeledEntryMulti "VNewNatRec" env $ sNext f $ sNext n $ sNext tid $ sNext ty $ sNext ez $ sNext x $ sLast es - + VServerSocket {} -> throw $ UnserializableException "VServerSocket" - VChan {} -> throw $ UnserializableException "VChan" + -- VChan {} -> throw $ UnserializableException "VChan" + VChan cc -> do + putStrLn "Trying to serialize VChan" + channelstate <- MVar.readMVar (ccChannelState cc) + case channelstate of + Connected mvarinfomap -> do + readList <- DC.allMessages (ccRead cc) + putStrLn "Read all incoming messages" + let readStartUnreadMVar = DC.messagesUnreadStart (ccRead cc) + readStartUnread <- MVar.readMVar readStartUnreadMVar + putStrLn "Read unreadpoint of incoming messages" + + writeList <- DC.allMessages (ccWrite cc) + putStrLn "Read all outgoing messages" + let writeStartUnreadMVar = DC.messagesUnreadStart (ccWrite cc) + writeStartUnread <- MVar.readMVar writeStartUnreadMVar + putStrLn "Read unreadpoint of outgoing messages" + + let partnerUserID = Data.Maybe.fromMaybe "" (ccPartnerUserID cc) + let ownUserID = Data.Maybe.fromMaybe "" (ccOwnUserID cc) + + putStrLn "Aquired all but connection address" + infomap <- MVar.readMVar mvarinfomap + let maybeconnectioninfo = Map.lookup partnerUserID infomap + case maybeconnectioninfo of + Nothing -> throw $ UnserializableException "VChan can only be serialized when in Connected mode" + Just connectioninfo -> do + case ciAddr connectioninfo of + Sock.SockAddrInet port hostname -> serializeLabeledEntryMulti "VChan" readList $ sNext readStartUnread $ sNext writeList $ sNext writeStartUnread $ sNext partnerUserID $ sNext ownUserID $ sNext (show port) $ sLast (show hostname) + _ -> throw $ UnserializableException "VChan currently only works over IPv4" + _ -> throw $ UnserializableException "VChan can only be serialized when in Connected mode" instance Serializable Multiplicity where serialize = \case @@ -78,7 +114,7 @@ instance Serializable Type where TLab arr -> serializeLabeledEntry "TLab" arr TFun mult ident t1 t2 -> serializeLabeledEntryMulti "TFun" mult $ sNext ident $ sNext t1 $ sLast t2 TPair ident t1 t2 -> serializeLabeledEntryMulti "TPair" ident $ sNext t1 $ sLast t2 - TSend ident t1 t2 -> serializeLabeledEntryMulti "TSend" ident $ sNext t1 $ sLast t2 + TSend ident t1 t2 -> serializeLabeledEntryMulti "TSend" ident $ sNext t1 $ sLast t2 TRecv ident t1 t2 -> serializeLabeledEntryMulti "TRecv" ident $ sNext t1 $ sLast t2 TCase e arr -> serializeLabeledEntryMulti "TCase" e $ sLast arr TEqn e1 e2 t -> serializeLabeledEntryMulti "TEqn" e1 $ sNext e2 $ sLast t @@ -170,19 +206,19 @@ serializeLabeledEntry label x = do return $ label ++ " (" ++ xString ++ ")" instance {-# OVERLAPPING #-} Serializable String where - serialize s = return $ "String:"++ show s + serialize s = return $ "String:"++ show s instance Serializable Int where - serialize i = return $ "Int:" ++ show i + serialize i = return $ "Int:" ++ show i instance Serializable Integer where - serialize i = return $ "Integer:" ++ show i + serialize i = return $ "Integer:" ++ show i instance Serializable Bool where - serialize b = return $ "Bool:" ++ show b + serialize b = return $ "Bool:" ++ show b instance Serializable Double where - serialize d = return $ "Double:" ++ show d + serialize d = return $ "Double:" ++ show d -- instance (Serializable a => Serializable (Set a)) where -- serialize as = "{" ++ serializeElements (elems as) ++ "}" @@ -191,7 +227,7 @@ instance Serializable Double where -- serialize arr = "["++ serializeElements arr ++"]" instance ((Serializable a, Serializable b) => Serializable (a, b)) where - serialize (s, t) = do + serialize (s, t) = do ss <- serialize s ts <- serialize t return $ "((" ++ ss ++ ") (" ++ ts ++ "))" @@ -200,7 +236,7 @@ instance {-# OVERLAPPING #-} Serializable PEnv where serialize arr = serializeLabeledArray "PEnv" arr instance {-# OVERLAPPING #-} Serializable PEnvEntry where - serialize (s, t) = do + serialize (s, t) = do ss <- serialize s ts <- serialize t return $ "PEnvEntry (" ++ ss ++ ") (" ++ ts ++ ")" @@ -234,7 +270,7 @@ serializeLabeledArray label arr = do serializeElements :: Serializable a => [a] -> IO String serializeElements [] = return "" serializeElements [x] = serialize x -serializeElements (x:xs) = do +serializeElements (x:xs) = do h <- serialize x - t <- serializeElements xs + t <- serializeElements xs return $ h ++ ", " ++ t \ No newline at end of file diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index 2c7bace..41b42c4 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -71,7 +71,8 @@ data Value data ConnectionInfo = ConnectionInfo {ciHandle :: Handle, ciAddr :: SockAddr, ciReadChannel :: DirectionalConnection Value, ciWriteChannel :: DirectionalConnection Value} deriving Eq -data CommunicationChannel = CommunicationChannel {ccRead :: DirectionalConnection Value, ccWrite :: DirectionalConnection Value, ccPartnerUserID :: Maybe String, ccOwnUserID :: Maybe String, ccPartnerAddress :: Maybe SockAddr, ccChannelState :: MVar.MVar ChannelState} +-- data CommunicationChannel = CommunicationChannel {ccRead :: DirectionalConnection Value, ccWrite :: DirectionalConnection Value, ccPartnerUserID :: Maybe String, ccOwnUserID :: Maybe String, ccPartnerAddress :: Maybe (MVar.MVar SockAddr), ccChannelState :: MVar.MVar ChannelState} +data CommunicationChannel = CommunicationChannel {ccRead :: DirectionalConnection Value, ccWrite :: DirectionalConnection Value, ccPartnerUserID :: Maybe String, ccOwnUserID :: Maybe String, ccChannelState :: MVar.MVar ChannelState} deriving Eq -- Change this to Maybe MVar SockAddr From f92ec13a4094cc5b24e78e2ef41f1b64d028dd0c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sat, 3 Dec 2022 19:04:35 +0100 Subject: [PATCH 033/229] VChans are now sendable --- src/Networking/DirectionalConnection.hs | 48 ++++++++++++------------- 1 file changed, 22 insertions(+), 26 deletions(-) diff --git a/src/Networking/DirectionalConnection.hs b/src/Networking/DirectionalConnection.hs index a0e3441..1b6f9fe 100644 --- a/src/Networking/DirectionalConnection.hs +++ b/src/Networking/DirectionalConnection.hs @@ -1,45 +1,41 @@ module Networking.DirectionalConnection (DirectionalConnection(..), newConnection, writeMessage, allMessages, readUnreadMessage) where -import Control.Concurrent.Chan import Control.Concurrent.MVar -data DirectionalConnection a = DirectionalConnection { messagesAll :: Chan a, messagesUnread :: Chan a, messagesUnreadStart :: MVar Int, messagesEnd :: MVar Int} +data DirectionalConnection a = DirectionalConnection { messages :: MVar [a], messagesUnreadStart :: MVar Int} deriving Eq +-- When a channel is duplicated there are no unread messages in the new channel, only the old one newConnection :: IO (DirectionalConnection a) newConnection = do - messagesAll <- newChan - messagesUnread <- dupChan messagesAll + messages <- newEmptyMVar + putMVar messages [] messagesUnreadStart <- newEmptyMVar putMVar messagesUnreadStart 0 - messagesEnd <- newEmptyMVar - putMVar messagesEnd 0 - return $ DirectionalConnection messagesAll messagesUnread messagesUnreadStart messagesEnd + return $ DirectionalConnection messages messagesUnreadStart writeMessage :: DirectionalConnection a -> a -> IO () writeMessage connection message = do - writeChan (messagesAll connection) message -- We only need to write it to one channel, since we duplicated them - modifyMVar_ (messagesEnd connection) (\i -> return $ i+1) + modifyMVar_ (messages connection) (\m -> do + return $ m ++ [message] + ) -- Gives all outMessages until this point allMessages :: DirectionalConnection a -> IO [a] -allMessages connection = do - messagesEnd <- readMVar $ messagesEnd connection - messagesDup <- dupChan $ messagesAll connection - giveMessages messagesDup messagesEnd - where - giveMessages :: Chan a -> Int -> IO [a] - giveMessages messages 0 = return [] - giveMessages messages count = do - x <- readChan messages - xs <- giveMessages messages $ count-1 - return (x:xs) +allMessages connection = readMVar (messages connection) readUnreadMessage :: DirectionalConnection a -> IO a -readUnreadMessage connection = do - modifyMVar_ (messagesUnreadStart connection) (\i -> return $ i+1) - readChan $ messagesUnread connection - - - +readUnreadMessage connection = modifyMVar (messagesUnreadStart connection) (\i -> do + messagesBind <- allMessages connection + return ((i+1), (messagesBind!!i)) + ) + + +test = do + mycon <- newConnection + writeMessage mycon "a" + writeMessage mycon "b" + allMessages mycon >>= print + readUnreadMessage mycon >>= print + allMessages mycon >>= print \ No newline at end of file From e317977cdfd41fa848f5395bec9001bed669d396 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sat, 3 Dec 2022 19:31:56 +0100 Subject: [PATCH 034/229] Fixed crashbug in DirectionalConnection --- src/Networking/DirectionalConnection.hs | 19 ++++++++++++++----- src/Networking/UserID.hs | 1 + 2 files changed, 15 insertions(+), 5 deletions(-) diff --git a/src/Networking/DirectionalConnection.hs b/src/Networking/DirectionalConnection.hs index 1b6f9fe..7c66447 100644 --- a/src/Networking/DirectionalConnection.hs +++ b/src/Networking/DirectionalConnection.hs @@ -1,4 +1,4 @@ -module Networking.DirectionalConnection (DirectionalConnection(..), newConnection, writeMessage, allMessages, readUnreadMessage) where +module Networking.DirectionalConnection (DirectionalConnection(..), newConnection, writeMessage, allMessages, readUnreadMessage, readUnreadMessageMaybe) where import Control.Concurrent.MVar @@ -25,11 +25,18 @@ writeMessage connection message = do allMessages :: DirectionalConnection a -> IO [a] allMessages connection = readMVar (messages connection) -readUnreadMessage :: DirectionalConnection a -> IO a -readUnreadMessage connection = modifyMVar (messagesUnreadStart connection) (\i -> do +readUnreadMessageMaybe :: DirectionalConnection a -> IO (Maybe a) +readUnreadMessageMaybe connection = modifyMVar (messagesUnreadStart connection) (\i -> do messagesBind <- allMessages connection - return ((i+1), (messagesBind!!i)) + if length messagesBind == i then return (i, Nothing) else return ((i+1), Just (messagesBind!!i)) ) + +readUnreadMessage :: DirectionalConnection a -> IO a +readUnreadMessage connection = do + maybeval <- readUnreadMessageMaybe connection + case maybeval of + Nothing -> readUnreadMessage connection + Just val -> return val test = do @@ -38,4 +45,6 @@ test = do writeMessage mycon "b" allMessages mycon >>= print readUnreadMessage mycon >>= print - allMessages mycon >>= print \ No newline at end of file + allMessages mycon >>= print + readUnreadMessage mycon >>= print + readUnreadMessage mycon >>= print \ No newline at end of file diff --git a/src/Networking/UserID.hs b/src/Networking/UserID.hs index d9e0e24..8088936 100644 --- a/src/Networking/UserID.hs +++ b/src/Networking/UserID.hs @@ -12,4 +12,5 @@ mapToChar val -- This is "probably" unique newRandomUserID :: IO String +-- newRandomUserID = map mapToChar . take 8 . randomRs (0, 61) <$> getStdGen newRandomUserID = map mapToChar . take 128 . randomRs (0, 61) <$> getStdGen From ea09a65e2ee37ff886bc11395efccb0b6b6f657c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 5 Dec 2022 14:42:03 +0100 Subject: [PATCH 035/229] More work towards channel sending --- src/Networking/Common.hs | 31 +++++++++++++++++++++++++ src/Networking/DirectionalConnection.hs | 12 +++++++++- src/Networking/Messages.hs | 2 +- src/ProcessEnvironment.hs | 27 +++++++++++++++++++++ 4 files changed, 70 insertions(+), 2 deletions(-) diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 11b869b..f51e6ff 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -25,6 +25,8 @@ import qualified ValueParsing.ValueGrammar as VG import qualified Networking.DirectionalConnection as DC import Networking.DirectionalConnection (DirectionalConnection) +import Network.Socket + {- -- communicate :: Chan.Chan Value -> Chan.Chan Value -> Socket -> IO () communicate read write socket = do @@ -159,3 +161,32 @@ waitForServerIntroduction handle = do _ -> do putStrLn $ "Error during server introduction, wrong message: "++ message throw $ NoIntroductionException message + + +getVChanFromSerial :: [Value] -> Int -> [Value] -> Int -> String -> String -> String -> String -> IO Value +getVChanFromSerial msgRead readCount msgWrite writeCount partnerID ownID port hostname = do + readDC <- DC.createConnection msgRead readCount + writeDC <- DC.createConnection msgWrite writeCount + channelstate <- MVar.newEmptyMVar + + -- Connect to partner + let hints = defaultHints { + addrFlags = [] + , addrSocketType = Stream + } + addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port + clientsocket <- openSocket $ head addrInfo + connect clientsocket $ addrAddress $ head addrInfo + handle <- getHandle clientsocket + sendMessage (Introduce ownID) handle + serverid <- waitForServerIntroduction handle + if partnerID == serverid then do + -- Hockup automatic message recieving + mvar <- liftIO MVar.newEmptyMVar + MVar.putMVar mvar (Map.fromList [(serverid, ConnectionInfo handle (addrAddress $ head addrInfo) readDC writeDC )]) + forkIO $ recieveMessagesID readDC mvar serverid + MVar.putMVar channelstate $ Connected mvar + else MVar.putMVar channelstate Disconnected + return $ VChan $ CommunicationChannel readDC writeDC (Just partnerID) (Just ownID) channelstate + where + openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) diff --git a/src/Networking/DirectionalConnection.hs b/src/Networking/DirectionalConnection.hs index 7c66447..665ab27 100644 --- a/src/Networking/DirectionalConnection.hs +++ b/src/Networking/DirectionalConnection.hs @@ -1,4 +1,4 @@ -module Networking.DirectionalConnection (DirectionalConnection(..), newConnection, writeMessage, allMessages, readUnreadMessage, readUnreadMessageMaybe) where +module Networking.DirectionalConnection (DirectionalConnection(..), newConnection, createConnection, writeMessage, allMessages, readUnreadMessage, readUnreadMessageMaybe) where import Control.Concurrent.MVar @@ -15,6 +15,16 @@ newConnection = do putMVar messagesUnreadStart 0 return $ DirectionalConnection messages messagesUnreadStart + +createConnection :: [a] -> Int -> IO (DirectionalConnection a) +createConnection messages unreadStart = do + msg <- newEmptyMVar + putMVar msg messages + messagesUnreadStart <- newEmptyMVar + putMVar messagesUnreadStart unreadStart + return $ DirectionalConnection msg messagesUnreadStart + + writeMessage :: DirectionalConnection a -> a -> IO () writeMessage connection message = do modifyMVar_ (messages connection) (\m -> do diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs index 13e0c98..01e15be 100644 --- a/src/Networking/Messages.hs +++ b/src/Networking/Messages.hs @@ -11,4 +11,4 @@ data Messages | NewValue Partner Value | SyncIncoming Partner [Value] | RequestSync Partner - | ChangePartnerAddress Partner Hostname Port + | ChangePartnerAddress Partner Hostname Port -- This is currently not used diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index 41b42c4..37b97ce 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -12,6 +12,7 @@ import qualified Data.Set as Set import Kinds (Multiplicity(..)) import Networking.DirectionalConnection +-- import qualified Networking.Common as NC import Network.Socket -- import qualified Networking.Common as NC @@ -82,6 +83,32 @@ data ChannelState = Connected {csConInfoMap :: MVar.MVar (Map.Map String Connect | Disabled -- Used when a Channel was sent --> Maybe we can automatically change this on serialization when we put this in a MVar deriving Eq + +-- If a channel is about to be send it should be deactivated +disableVChan :: Value -> IO () +disableVChan = \case + VSend v -> disableVChan v + VPair v1 v2 -> disableVChan v1 >> disableVChan v2 + VFunc penv _ _ -> disableVChanArr penv + VDynCast v _ -> disableVChan v + VFuncCast v _ _ -> disableVChan v + VRec penv _ _ _ _ -> disableVChanArr penv + VNewNatRec penv _ _ _ _ _ _ _ -> disableVChanArr penv + VChan cc -> do + channelstate <- MVar.takeMVar $ ccChannelState cc + case channelstate of + Connected infomap -> MVar.putMVar (ccChannelState cc) Disabled + _ -> MVar.putMVar (ccChannelState cc) channelstate + _ -> return () + where + disableVChanArr :: PEnv -> IO () + disableVChanArr [] = return () + disableVChanArr (x:xs) = disableVChan (snd x) >> disableVChanArr xs + + + + + instance Show Value where show = \case VUnit -> "VUnit" From f3161a3e9420fd648c4e375a4109fcf05aac3454 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 5 Dec 2022 16:42:33 +0100 Subject: [PATCH 036/229] Progress towards sending vchans --- src/Networking/Common.hs | 95 ++++++++++++----------------- src/Networking/NetworkConnection.hs | 19 +----- src/Networking/Server.hs | 15 +---- src/PrettySyntax.hs | 1 + src/ProcessEnvironment.hs | 3 + src/ValueParsing/ValueGrammar.y | 2 +- 6 files changed, 47 insertions(+), 88 deletions(-) diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index f51e6ff..f096c46 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -25,32 +25,6 @@ import qualified ValueParsing.ValueGrammar as VG import qualified Networking.DirectionalConnection as DC import Networking.DirectionalConnection (DirectionalConnection) -import Network.Socket - -{- --- communicate :: Chan.Chan Value -> Chan.Chan Value -> Socket -> IO () -communicate read write socket = do - hdl <- socketToHandle socket ReadWriteMode - hSetBuffering hdl NoBuffering - forkIO (sendWritten write hdl) - recieveReadable read hdl - where - sendWritten write handle = do - message <- readChan write - putStrLn $ "Sending message:" ++ SV.serialize message - hPutStrLn handle (SV.serialize message ++" ") - sendWritten write handle - - recieveReadable read handle = do - message <- hGetLine handle - putStrLn $ "Recieved message:" ++ message - case VT.runAlex message VG.parseValues of - Left err -> putStrLn $ "Error during recieving a networkmessage: "++err - Right deserial -> writeChan read deserial - recieveReadable read handle --} - - newtype ServerException = NoIntroductionException String deriving Eq @@ -84,13 +58,6 @@ sendMessageID value handlemapmvar userid = do handle <- userIDToHandle handlemapmvar userid hPutStrLn handle (serializedValue ++ " ") - {- - maybehandle <- userIDToHandle handlemapmvar userid - case maybehandle of - Just handle -> hPutStrLn handle (serializedValue ++" ") - Nothing -> putStrLn $ "Error " ++ userid ++ " not found while trying to recieve messages" - -} - recieveMessagesID :: DirectionalConnection Value -> MVar.MVar (Map.Map String ConnectionInfo) -> String -> IO () recieveMessagesID chan mvar userid = do handle <- userIDToHandle mvar userid @@ -100,20 +67,12 @@ recieveMessagesID chan mvar userid = do -- case VT.runAlex message VG.parseValues of Left err -> putStrLn $ "Error during recieving a networkmessage: "++err Right deserialmessages -> case deserialmessages of - NewValue userid val -> DC.writeMessage chan val + NewValue userid val -> do + valCleaned <- replaceVChanSerial val -- Replaces VChanSerial with VChans and their appropriate connection + DC.writeMessage chan valCleaned _ -> do serial <- NSerialize.serialize deserialmessages putStrLn $ "Error unsupported networkmessage: "++ serial - {- - case maybehandle of - Just handle -> do - message <- hGetLine handle - putStrLn $ "Recieved message:" ++ message - case VT.runAlex message VG.parseValues of - Left err -> putStrLn $ "Error during recieving a networkmessage: "++err - Right deserial -> writeChan chan deserial - Nothing -> putStrLn $ "Error " ++ userid ++ " not found while trying to recieve messages" - -} recieveMessagesID chan mvar userid @@ -123,18 +82,6 @@ sendMessage value handle = do putStrLn $ "Sending message:" ++ serializedValue hPutStrLn handle (serializedValue ++" ") - -{- -recieveMessages :: Chan.Chan Value -> Handle -> IO () -recieveMessages chan handle = do - message <- hGetLine handle - putStrLn $ "Recieved message:" ++ message - case VT.runAlex message VG.parseValues of - Left err -> putStrLn $ "Error during recieving a networkmessage: "++err - Right deserial -> writeChan chan deserial - recieveMessages chan handle --} - getHandle :: Socket -> IO Handle getHandle socket = do hdl <- socketToHandle socket ReadWriteMode @@ -163,6 +110,40 @@ waitForServerIntroduction handle = do throw $ NoIntroductionException message +replaceVChanSerial :: Value -> IO Value +replaceVChanSerial input = case input of + VSend v -> do + nv <- replaceVChanSerial v + return $ VSend nv + VPair v1 v2 -> do + nv1 <- replaceVChanSerial v1 + nv2 <- replaceVChanSerial v2 + return $ VPair nv1 nv2 + VFunc penv a b -> do + newpenv <- replaceVChanSerialPEnv penv + return $ VFunc newpenv a b + VDynCast v g -> do + nv <- replaceVChanSerial v + return $ VDynCast nv g + VFuncCast v a b -> do + nv <- replaceVChanSerial v + return $ VFuncCast nv a b + VRec penv a b c d -> do + newpenv <- replaceVChanSerialPEnv penv + return $ VRec newpenv a b c d + VNewNatRec penv a b c d e f g -> do + newpenv <- replaceVChanSerialPEnv penv + return $ VNewNatRec newpenv a b c d e f g + VChanSerial r ri w wi pid oid p h -> getVChanFromSerial r ri w wi pid oid p h + _ -> return input + where + replaceVChanSerialPEnv :: [(String, Value)] -> IO [(String, Value)] + replaceVChanSerialPEnv [] = return [] + replaceVChanSerialPEnv (x:xs) = do + newval <- replaceVChanSerial $ snd x + rest <- replaceVChanSerialPEnv xs + return $ (fst x, newval):rest + getVChanFromSerial :: [Value] -> Int -> [Value] -> Int -> String -> String -> String -> String -> IO Value getVChanFromSerial msgRead readCount msgWrite writeCount partnerID ownID port hostname = do readDC <- DC.createConnection msgRead readCount @@ -189,4 +170,4 @@ getVChanFromSerial msgRead readCount msgWrite writeCount partnerID ownID port ho else MVar.putMVar channelstate Disconnected return $ VChan $ CommunicationChannel readDC writeDC (Just partnerID) (Just ownID) channelstate where - openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) \ No newline at end of file diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index c0e26a0..554b868 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -1,18 +1 @@ -module Networking.NetworkConnection where - -{- -import Networking.DirectionalConnection -import GHC.IO.Handle -import Network.Run.TCP - - -data NetworkingConnection a = NetworkingConnection {ingoing :: DirectionalConnection a, outgoing :: DirectionalConnection a, networkHandle :: Handle} - -type Hostname = String -type Port = Int - -newConnection :: Maybe Hostname -> Port -> NetworkingConnection a -newConnection maybeHost port = do - case maybeHost of - Nothing -> runTCPServer Nothing (show port) (NC.communicate r w) - -} +module Networking.NetworkConnection where \ No newline at end of file diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 5d73b78..d63e41c 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -20,16 +20,7 @@ import ProcessEnvironment import Control.Exception import qualified Networking.UserID as UserID import qualified Networking.Messages as Messages -import qualified Networking.DirectionalConnection as NC - -{-newtype ServerException = NoIntroductionException String - deriving Eq - -instance Show ServerException where - show = \case - NoIntroductionException s -> "Client didn't introduce itself, but sent: " ++ s - -instance Exception ServerException-} +import qualified Networking.DirectionalConnection as ND createServer :: Int -> IO (MVar.MVar (Map String ConnectionInfo), Chan.Chan String, String) @@ -62,8 +53,8 @@ acceptClient :: MVar.MVar (Map String ConnectionInfo) -> Chan.Chan String -> (So acceptClient mvar chan clientsocket serverid = do hdl <- NC.getHandle $ fst clientsocket userid <- waitForIntroduction hdl serverid - r <- NC.newConnection - w <- NC.newConnection + r <- ND.newConnection + w <- ND.newConnection MVar.modifyMVar_ mvar (return . insert userid (ConnectionInfo hdl (snd clientsocket) r w)) forkIO $ NC.recieveMessagesID r mvar userid Chan.writeChan chan userid diff --git a/src/PrettySyntax.hs b/src/PrettySyntax.hs index 77415d1..dfa4849 100644 --- a/src/PrettySyntax.hs +++ b/src/PrettySyntax.hs @@ -169,6 +169,7 @@ instance Pretty Value where VDouble d -> pretty $ show d VString s -> pretty $ show s VChan {} -> pretty "VChan" + VChanSerial {} -> pretty "VChanSerial" VSend v -> pretty "VSend" VPair a b -> pretty "<" <+> pretty a <+> pretty ", " <+> pretty b <+> pretty ">" VType t -> pretty t diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index 37b97ce..02c3a78 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -53,6 +53,7 @@ data Value -- end, so we do not read our own written values -- | VChan (C.Chan Value) (C.Chan Value) (Maybe Handle) (Maybe SockAddr) (Maybe String) (Maybe String) | VChan CommunicationChannel + | VChanSerial [Value] Int [Value] Int String String String String -- Read Chan Write Chan Handle of Con Address of other other Userid own UserID -- | VChan (C.Chan Value) (C.Chan Value) | VSend Value @@ -69,6 +70,7 @@ data Value -- This is the server id deriving Eq + data ConnectionInfo = ConnectionInfo {ciHandle :: Handle, ciAddr :: SockAddr, ciReadChannel :: DirectionalConnection Value, ciWriteChannel :: DirectionalConnection Value} deriving Eq @@ -117,6 +119,7 @@ instance Show Value where VDouble d -> "VDouble " ++ show d VString s -> "VString \"" ++ show s ++ "\"" VChan {} -> "VChan" + VChanSerial {} -> "VChanSerial" VSend v -> "VSend (" ++ show v ++ ")" VPair a b -> "VPair <" ++ show a ++ ", " ++ show b ++ ">" VType t -> "VType " ++ show t diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 9dc40f5..0b861fd 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -171,7 +171,7 @@ Values : vunit { VUnit } | vint '(' int ')' {VInt $3} | vdouble '(' double ')' {VDouble $3} | vstring '(' String ')' {VString $3 } --- | vchan '(' SValuesArray ')' '(' SValuesArray ')' {VChan $3 $6} + | vchan '(' SValuesArray ')' '(' int ')' '(' SValuesArray ')' '(' int ')' '(' String ')' '(' String ')' '(' String ')' '(' String ')' {VChanSerial $3 $6 $9 $12 $15 $18 $21 $24 } | vsend '(' Values ')' {VSend $3} | vpair '(' Values ')' '(' Values ')' {VPair $3 $6} | vtype '(' Type ')' {VType $3} From a75b78d05722a05ad89faa826e2cecad3096e9af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 5 Dec 2022 17:10:40 +0100 Subject: [PATCH 037/229] More debug messages --- dev-examples/simple/test.ldgvnw | 22 ++++++++++++++++++++++ src/Networking/Common.hs | 15 +++++++++++++-- src/Networking/Server.hs | 3 +++ 3 files changed, 38 insertions(+), 2 deletions(-) create mode 100644 dev-examples/simple/test.ldgvnw diff --git a/dev-examples/simple/test.ldgvnw b/dev-examples/simple/test.ldgvnw new file mode 100644 index 0000000..c77c93a --- /dev/null +++ b/dev-examples/simple/test.ldgvnw @@ -0,0 +1,22 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit + +val send2 (c: SendInt) (d: SendInt) = + let x = ((send c) 1) in + let z = ((send d) 1) in + let y = ((send x) 42) in + let w = ((send z) 42) in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val main : Unit +val main = + let con = (connect "127.0.0.1" 4242 SendInt) in -- This cannot be localhost, since this might break on containerized images + let co2 = (connect "127.0.0.1" 4242 SendInt) in -- This cannot be localhost, since this might break on containerized images + send2 con co2 diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index f096c46..8216e6c 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -134,7 +134,9 @@ replaceVChanSerial input = case input of VNewNatRec penv a b c d e f g -> do newpenv <- replaceVChanSerialPEnv penv return $ VNewNatRec newpenv a b c d e f g - VChanSerial r ri w wi pid oid p h -> getVChanFromSerial r ri w wi pid oid p h + VChanSerial r ri w wi pid oid p h -> do + putStrLn "Attempting to deserialize a VChanSerial" + getVChanFromSerial r ri w wi pid oid p h _ -> return input where replaceVChanSerialPEnv :: [(String, Value)] -> IO [(String, Value)] @@ -155,18 +157,27 @@ getVChanFromSerial msgRead readCount msgWrite writeCount partnerID ownID port ho addrFlags = [] , addrSocketType = Stream } + + putStrLn $ "getVChanFromSerial: Trying to connect to new partner: " ++ hostname ++ ":" ++ port addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port clientsocket <- openSocket $ head addrInfo + putStrLn "getVChanFromSerial: Aquired socket" connect clientsocket $ addrAddress $ head addrInfo + putStrLn "getVChanFromSerial: Connected to socket" handle <- getHandle clientsocket + putStrLn "getVChanFromSerial: Converted to handle" sendMessage (Introduce ownID) handle + putStrLn "getVChanFromSerial: Waiting for handshake" serverid <- waitForServerIntroduction handle + putStrLn "getVChanFromSerial: Handshake recieved" if partnerID == serverid then do - -- Hockup automatic message recieving + putStrLn "getVChanFromSerial: Handshake valid" + -- Hookup automatic message recieving mvar <- liftIO MVar.newEmptyMVar MVar.putMVar mvar (Map.fromList [(serverid, ConnectionInfo handle (addrAddress $ head addrInfo) readDC writeDC )]) forkIO $ recieveMessagesID readDC mvar serverid MVar.putMVar channelstate $ Connected mvar + putStrLn "getVChanFromSerial: Message revieving hooked up" else MVar.putMVar channelstate Disconnected return $ VChan $ CommunicationChannel readDC writeDC (Just partnerID) (Just ownID) channelstate where diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index d63e41c..6d334ed 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -44,7 +44,10 @@ createServer port = do acceptClients :: MVar.MVar (Map String ConnectionInfo) -> Chan.Chan String -> Socket -> String-> IO () acceptClients mvar chan socket serverid = do + putStrLn "Waiting for clients" clientsocket <- accept socket + putStrLn "Accepted new client" + forkIO $ acceptClient mvar chan clientsocket serverid acceptClients mvar chan socket serverid From 936b1757827eaa89d27e010f9197cb59db4ae7b6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 5 Dec 2022 17:26:10 +0100 Subject: [PATCH 038/229] fixed a bug where the partner userid was used instead of the own --- src/Interpreter.hs | 6 ++++-- src/Networking/Common.hs | 6 +++--- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 868b443..adf536a 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -293,8 +293,10 @@ interpretApp _ (VSend v@(VChan cc)) w = do liftIO $ DC.writeMessage (ccWrite cc) w channelstate <- liftIO $ MVar.readMVar (ccChannelState cc) case ccPartnerUserID cc of - Just userid -> liftIO $ NC.sendMessageID w (csConInfoMap channelstate) userid - Nothing -> pure () + Just partnerid -> case ccOwnUserID cc of + Just ownuserid -> liftIO $ NC.sendMessageID w (csConInfoMap channelstate) partnerid ownuserid + Nothing -> pure () + Nothing -> pure () --case handle of -- Nothing -> pure () -- Just hdl -> liftIO $ NC.sendMessage w hdl diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 8216e6c..69cfc69 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -51,11 +51,11 @@ userIDToHandle mvar userid = do Just connectioninfo -> return $ ciHandle connectioninfo Nothing -> userIDToHandle mvar userid -sendMessageID :: Value -> MVar.MVar (Map.Map String ConnectionInfo) -> String -> IO () -sendMessageID value handlemapmvar userid = do +sendMessageID :: Value -> MVar.MVar (Map.Map String ConnectionInfo) -> String -> String -> IO () +sendMessageID value handlemapmvar partnerid userid = do serializedValue <- NSerialize.serialize $ NewValue userid value putStrLn $ "Sending message:" ++ serializedValue - handle <- userIDToHandle handlemapmvar userid + handle <- userIDToHandle handlemapmvar partnerid hPutStrLn handle (serializedValue ++ " ") recieveMessagesID :: DirectionalConnection Value -> MVar.MVar (Map.Map String ConnectionInfo) -> String -> IO () From d293d156a9218fd0115ee42666eec7f8c09fc310 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 5 Dec 2022 19:18:07 +0100 Subject: [PATCH 039/229] Update ProcessEnvironment.hs --- src/ProcessEnvironment.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index 02c3a78..b4cac23 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -54,6 +54,7 @@ data Value -- | VChan (C.Chan Value) (C.Chan Value) (Maybe Handle) (Maybe SockAddr) (Maybe String) (Maybe String) | VChan CommunicationChannel | VChanSerial [Value] Int [Value] Int String String String String + -- Maybe replace this with an VChan Either comchan or this -- Read Chan Write Chan Handle of Con Address of other other Userid own UserID -- | VChan (C.Chan Value) (C.Chan Value) | VSend Value From 1492b45f7ae982d8edd122a0f746066ed3e5a6ec Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 6 Dec 2022 18:50:26 +0100 Subject: [PATCH 040/229] added new networking code --- src/Networking/Client.hs | 65 ++++++++++++++++- src/Networking/Common.hs | 19 ++++- src/Networking/Messages.hs | 4 +- src/Networking/NetworkConnection.hs | 22 +++++- src/Networking/Server.hs | 104 ++++++++++++++++++++++++++-- src/ValueParsing/ValueGrammar.y | 2 +- 6 files changed, 202 insertions(+), 14 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index b90d829..56e27b1 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -1 +1,64 @@ -module Networking.Client where \ No newline at end of file +module Networking.Client where + +import Networking.NetworkConnection as NCon +import qualified Networking.Common as NC +import ProcessEnvironment +import qualified ValueParsing.ValueTokens as VT +import qualified ValueParsing.ValueGrammar as VG +import Networking.Messages +import qualified Control.Concurrent.MVar as MVar +import qualified Networking.DirectionalConnection as DC +import Network.Socket +import qualified Networking.Messages as Messages +import qualified Networking.NetworkConnection as Networking +import qualified Networking.UserID as UserID +import qualified Data.Map as Map +import GHC.IO.Handle +import qualified Data.Maybe + +sendMessage :: NetworkConnection Value -> Value -> IO () +sendMessage networkconnection val = do + let hints = defaultHints { + addrFlags = [] + , addrSocketType = Stream + } + connectionstate <- MVar.takeMVar $ ncConnectionState networkconnection + case connectionstate of + NCon.Connected hostname port -> do + addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port + clientsocket <- NC.openSocket $ head addrInfo + connect clientsocket $ addrAddress $ head addrInfo + handle <- NC.getHandle clientsocket + putStrLn "Client connected: Sending Message" + NC.sendMessage (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) val) handle + DC.writeMessage (ncWrite networkconnection) val + hClose handle + NCon.Disconnected -> putStrLn "Error when sending message: This channel is disconnected" + NCon.Emulated -> DC.writeMessage (ncWrite networkconnection) val + MVar.putMVar (ncConnectionState networkconnection) connectionstate + + +initialConnect :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> IO () +initialConnect mvar hostname port = do + let hints = defaultHints { + addrFlags = [] + , addrSocketType = Stream + } + networkconnectionmap <- MVar.takeMVar mvar + addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port + clientsocket <- NC.openSocket $ head addrInfo + connect clientsocket $ addrAddress $ head addrInfo + handle <- NC.getHandle clientsocket + ownuserid <- UserID.newRandomUserID + putStrLn "Client connected: Introducing" + NC.sendMessage (Messages.Introduce ownuserid) handle + introductionanswer <- NC.waitForServerIntroduction handle + putStrLn "Finished Handshake" + hClose handle + + newConnection <- newNetworkConnection introductionanswer ownuserid hostname port + let newNetworkconnectionmap = Map.insert introductionanswer newConnection networkconnectionmap + MVar.putMVar mvar newNetworkconnectionmap + + + diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 69cfc69..3106049 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -24,6 +24,7 @@ import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG import qualified Networking.DirectionalConnection as DC import Networking.DirectionalConnection (DirectionalConnection) +import Networking.Serialize (Serializable) newtype ServerException = NoIntroductionException String deriving Eq @@ -58,6 +59,7 @@ sendMessageID value handlemapmvar partnerid userid = do handle <- userIDToHandle handlemapmvar partnerid hPutStrLn handle (serializedValue ++ " ") + recieveMessagesID :: DirectionalConnection Value -> MVar.MVar (Map.Map String ConnectionInfo) -> String -> IO () recieveMessagesID chan mvar userid = do handle <- userIDToHandle mvar userid @@ -82,6 +84,18 @@ sendMessage value handle = do putStrLn $ "Sending message:" ++ serializedValue hPutStrLn handle (serializedValue ++" ") +recieveMessage :: Handle -> IO (Maybe Messages) +recieveMessage handle = do + message <- hGetLine handle + case VT.runAlex message VG.parseMessages of + -- case VT.runAlex message VG.parseValues of + Left err -> do + putStrLn $ "Error during recieving a networkmessage: "++err + return Nothing + Right deserialmessage -> return $ Just deserialmessage + + + getHandle :: Socket -> IO Handle getHandle socket = do hdl <- socketToHandle socket ReadWriteMode @@ -180,5 +194,6 @@ getVChanFromSerial msgRead readCount msgWrite writeCount partnerID ownID port ho putStrLn "getVChanFromSerial: Message revieving hooked up" else MVar.putMVar channelstate Disconnected return $ VChan $ CommunicationChannel readDC writeDC (Just partnerID) (Just ownID) channelstate - where - openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) \ No newline at end of file + + +openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) \ No newline at end of file diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs index 01e15be..938485f 100644 --- a/src/Networking/Messages.hs +++ b/src/Networking/Messages.hs @@ -4,11 +4,11 @@ import ProcessEnvironment type Partner = String type Hostname = String -type Port = Int +type Port = String data Messages = Introduce Partner | NewValue Partner Value | SyncIncoming Partner [Value] | RequestSync Partner - | ChangePartnerAddress Partner Hostname Port -- This is currently not used + | ChangePartnerAddress Partner Hostname Port diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index 554b868..b89041a 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -1 +1,21 @@ -module Networking.NetworkConnection where \ No newline at end of file +module Networking.NetworkConnection where + +import Networking.DirectionalConnection +import qualified Control.Concurrent.MVar as MVar + +data NetworkConnection a = NetworkConnection {ncRead :: DirectionalConnection a, ncWrite :: DirectionalConnection a, ncPartnerUserID :: Maybe String, ncOwnUserID :: Maybe String, ncConnectionState :: MVar.MVar ConnectionState} + deriving Eq + +data ConnectionState = Connected {csHostname :: String, csPort :: String} + | Disconnected + | Emulated + deriving Eq + + +newNetworkConnection :: String -> String -> String -> String -> IO (NetworkConnection a) +newNetworkConnection partnerID ownID hostname port = do + read <- newConnection + write <- newConnection + connectionstate <- MVar.newEmptyMVar + MVar.putMVar connectionstate $ Connected hostname port + return $ NetworkConnection read write (Just partnerID) (Just ownID) connectionstate \ No newline at end of file diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 6d334ed..955984c 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -5,7 +5,7 @@ import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.Chan as Chan import Control.Concurrent (forkIO) import Control.Monad.IO.Class -import Data.Map +import qualified Data.Map as Map import GHC.IO.Handle import Network.Socket @@ -14,7 +14,6 @@ import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG import qualified Networking.Common as NC import qualified Networking.Serialize as NSerialize -import qualified Networking.UserID as UserID import ProcessEnvironment import Control.Exception @@ -22,8 +21,13 @@ import qualified Networking.UserID as UserID import qualified Networking.Messages as Messages import qualified Networking.DirectionalConnection as ND +import Networking.NetworkConnection +import qualified Control.Concurrent as MVar +import Networking.NetworkConnection (newNetworkConnection, NetworkConnection (ncConnectionState)) +import Networking.Messages (Messages(Introduce)) + -createServer :: Int -> IO (MVar.MVar (Map String ConnectionInfo), Chan.Chan String, String) +createServer :: Int -> IO (MVar.MVar (Map.Map String ConnectionInfo), Chan.Chan String, String) createServer port = do serverid <- UserID.newRandomUserID sock <- liftIO $ socket AF_INET Stream 0 @@ -37,12 +41,98 @@ createServer port = do liftIO $ bind sock $ addrAddress $ head addrInfo liftIO $ listen sock 2 mvar <- MVar.newEmptyMVar - MVar.putMVar mvar empty + MVar.putMVar mvar Map.empty chan <- Chan.newChan forkIO $ acceptClients mvar chan sock serverid return (mvar, chan, serverid) -acceptClients :: MVar.MVar (Map String ConnectionInfo) -> Chan.Chan String -> Socket -> String-> IO () + +createServerNew :: Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), Chan.Chan String) +createServerNew port = do + serverid <- UserID.newRandomUserID + sock <- liftIO $ socket AF_INET Stream 0 + liftIO $ setSocketOption sock ReuseAddr 1 + let hints = defaultHints { + addrFlags = [AI_PASSIVE] + , addrSocketType = Stream + } + addrInfo <- liftIO $ getAddrInfo (Just hints) Nothing $ Just $ show port + + liftIO $ bind sock $ addrAddress $ head addrInfo + liftIO $ listen sock 2 + mvar <- MVar.newEmptyMVar + MVar.putMVar mvar Map.empty + chan <- Chan.newChan + forkIO $ acceptClientsNew mvar chan sock + return (mvar, chan) + +acceptClientsNew :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> Chan.Chan String -> Socket -> IO () +acceptClientsNew mvar chan socket = do + putStrLn "Waiting for clients" + clientsocket <- accept socket + putStrLn "Accepted new client" + + forkIO $ acceptClientNew mvar chan clientsocket + acceptClientsNew mvar chan socket + +acceptClientNew :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> Chan.Chan String -> (Socket, SockAddr) -> IO () +acceptClientNew mvar chan clientsocket = do + hdl <- NC.getHandle $ fst clientsocket + message <- hGetLine hdl + putStrLn $ "Recieved message:" ++ message + case VT.runAlex message VG.parseMessages of + -- case VT.runAlex message VG.parseValues of + Left err -> putStrLn $ "Error during recieving a networkmessage: "++err + Right deserialmessages -> case deserialmessages of + NewValue userid val -> do + networkconnectionmap <- MVar.takeMVar mvar + case Map.lookup userid networkconnectionmap of + Just networkconnection -> do -- This means we habe already spoken to this client + valCleaned <- NC.replaceVChanSerial val -- Replaces VChanSerial with VChans and their appropriate connection + ND.writeMessage (ncRead networkconnection) valCleaned + MVar.putMVar mvar networkconnectionmap + Nothing -> do + putStrLn "Error during recieving a networkmessage: Introduction is needed prior to sending values!" + MVar.putMVar mvar networkconnectionmap + Introduce userid -> do + networkconnectionmap <- MVar.takeMVar mvar + case Map.lookup userid networkconnectionmap of + Just networkconnection -> do + putStrLn "Error during recieving a networkmessage: Already introduced to this client!" + MVar.putMVar mvar networkconnectionmap + Nothing -> case snd clientsocket of -- This client is new + SockAddrInet port hostname -> do + serverid <- UserID.newRandomUserID + networkconnection <- newNetworkConnection userid serverid (show hostname) (show port) + let newnetworkconnectionmap = Map.insert userid networkconnection networkconnectionmap + MVar.putMVar mvar newnetworkconnectionmap + NC.sendMessage (Introduce serverid) hdl -- Answer with own serverid + Chan.writeChan chan userid -- Adds the new user to the users that can be accepted by the server + + _ -> do + putStrLn "Error during recieving a networkmessage: only ipv4 is currently supported!" + MVar.putMVar mvar networkconnectionmap + + + ChangePartnerAddress userid hostname port -> do + networkconnectionmap <- MVar.takeMVar mvar + case Map.lookup userid networkconnectionmap of + Just networkconnection -> do -- Change to current network address + let constate = ncConnectionState networkconnection + _ <- MVar.takeMVar constate + MVar.putMVar constate $ Networking.NetworkConnection.Connected hostname port + MVar.putMVar mvar networkconnectionmap + Nothing -> pure () -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that + + _ -> do + serial <- NSerialize.serialize deserialmessages + putStrLn $ "Error unsupported networkmessage: "++ serial + hClose hdl + + + + +acceptClients :: MVar.MVar (Map.Map String ConnectionInfo) -> Chan.Chan String -> Socket -> String-> IO () acceptClients mvar chan socket serverid = do putStrLn "Waiting for clients" clientsocket <- accept socket @@ -52,13 +142,13 @@ acceptClients mvar chan socket serverid = do acceptClients mvar chan socket serverid -acceptClient :: MVar.MVar (Map String ConnectionInfo) -> Chan.Chan String -> (Socket, SockAddr) -> String -> IO () +acceptClient :: MVar.MVar (Map.Map String ConnectionInfo) -> Chan.Chan String -> (Socket, SockAddr) -> String -> IO () acceptClient mvar chan clientsocket serverid = do hdl <- NC.getHandle $ fst clientsocket userid <- waitForIntroduction hdl serverid r <- ND.newConnection w <- ND.newConnection - MVar.modifyMVar_ mvar (return . insert userid (ConnectionInfo hdl (snd clientsocket) r w)) + MVar.modifyMVar_ mvar (return . Map.insert userid (ConnectionInfo hdl (snd clientsocket) r w)) forkIO $ NC.recieveMessagesID r mvar userid Chan.writeChan chan userid diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 0b861fd..e70015b 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -259,7 +259,7 @@ Messages : nintroduce '(' String ')' {Introduce $3} | nnewvalue '(' String ')''(' Values ')' {NewValue $3 $6} | nsyncincoming '(' String ')''(' SValuesArray ')' {SyncIncoming $3 $6} | nrequestsync '(' String ')' {RequestSync $3} - | nchangepartneraddress '(' String ')' '(' String ')' '(' int ')' {ChangePartnerAddress $3 $6 $9} + | nchangepartneraddress '(' String ')' '(' String ')' '(' String ')' {ChangePartnerAddress $3 $6 $9} PEnvEntry : penventry '(' String ')' '(' Values ')' {($3, $6)} From c12cbd20bc9cb9820aa3e8664abe84976d21ff53 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 6 Dec 2022 19:54:38 +0100 Subject: [PATCH 041/229] updated clients to have a sock --- dev-examples/simple/client-new.ldgvnw | 20 ++++++++++++++++++++ dev-examples/simple/server.ldgvnw | 6 +++--- src/Interpreter.hs | 2 +- src/Networking/Messages.hs | 3 +++ src/Networking/Serialize.hs | 4 +++- src/Networking/Server.hs | 4 ++-- src/Parsing/Grammar.y | 3 ++- src/PrettySyntax.hs | 2 +- src/Syntax.hs | 6 +++--- src/TCTyping.hs | 2 +- 10 files changed, 39 insertions(+), 13 deletions(-) create mode 100644 dev-examples/simple/client-new.ldgvnw diff --git a/dev-examples/simple/client-new.ldgvnw b/dev-examples/simple/client-new.ldgvnw new file mode 100644 index 0000000..509798d --- /dev/null +++ b/dev-examples/simple/client-new.ldgvnw @@ -0,0 +1,20 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let y = ((send x) 42) in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val main : Unit +val main = + let sock = (create 4343) in + let con = (connect sock SendInt "127.0.0.1" 4242 ) in -- This cannot be localhost, since this might break on containerized images + send2 con diff --git a/dev-examples/simple/server.ldgvnw b/dev-examples/simple/server.ldgvnw index 56004ce..e9f99db 100644 --- a/dev-examples/simple/server.ldgvnw +++ b/dev-examples/simple/server.ldgvnw @@ -15,6 +15,6 @@ val add2 (c1: dualof SendInt) = val main : Int val main = - let con = (create 4242) in - let sock = (accept con (dualof SendInt)) in - add2 sock + let sock = (create 4242) in + let con = (accept sock (dualof SendInt)) in + add2 con diff --git a/src/Interpreter.hs b/src/Interpreter.hs index adf536a..90fcab6 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -207,7 +207,7 @@ eval = \case return $ VChan $ CommunicationChannel (ciReadChannel clientuser) (ciWriteChannel clientuser) (Just newuser) (Just serverid) channelstate _ -> throw $ NotAnExpectedValueException "VServerSocket" val - Connect e1 e2 t -> do + Connect e0 e1 e2 t -> do r <- liftIO DC.newConnection w <- liftIO DC.newConnection liftIO $ C.traceIO "Client trying to connect" diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs index 938485f..b086362 100644 --- a/src/Networking/Messages.hs +++ b/src/Networking/Messages.hs @@ -8,7 +8,10 @@ type Port = String data Messages = Introduce Partner + | IntroduceClient Partner Port + | IntroduceServer Partner | NewValue Partner Value | SyncIncoming Partner [Value] | RequestSync Partner | ChangePartnerAddress Partner Hostname Port + deriving Eq diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index 032507f..ba34636 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -38,6 +38,8 @@ class Serializable a where instance Serializable Messages where serialize = \case Introduce p -> serializeLabeledEntry "NIntroduce" p + IntroduceClient p port -> serializeLabeledEntryMulti "NIntroduceClient" p $ sLast port + IntroduceServer p -> serializeLabeledEntry "NIntroduceServer" p NewValue p v -> serializeLabeledEntryMulti "NNewValue" p $ sLast v SyncIncoming p vs -> serializeLabeledEntryMulti "NSyncIncoming" p $ sLast vs RequestSync p -> serializeLabeledEntry "NRequestSync" p @@ -146,7 +148,7 @@ instance Serializable Exp where Cast e t1 t2 -> serializeLabeledEntryMulti "ECast" e $ sNext t1 $ sLast t2 Create e -> serializeLabeledEntry "ECreate" e - Connect e1 e2 t -> serializeLabeledEntryMulti "EConnect" e1 $ sNext e2 $ sLast t + Connect e0 e1 e2 t -> serializeLabeledEntryMulti "EConnect" e0 $ sNext e1 $ sNext e2 $ sLast t Accept e t -> serializeLabeledEntryMulti "EAccept" e $ sLast t instance Serializable (MathOp Exp) where diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 955984c..7662878 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -94,7 +94,7 @@ acceptClientNew mvar chan clientsocket = do Nothing -> do putStrLn "Error during recieving a networkmessage: Introduction is needed prior to sending values!" MVar.putMVar mvar networkconnectionmap - Introduce userid -> do + IntroduceClient userid clientport -> do networkconnectionmap <- MVar.takeMVar mvar case Map.lookup userid networkconnectionmap of Just networkconnection -> do @@ -103,7 +103,7 @@ acceptClientNew mvar chan clientsocket = do Nothing -> case snd clientsocket of -- This client is new SockAddrInet port hostname -> do serverid <- UserID.newRandomUserID - networkconnection <- newNetworkConnection userid serverid (show hostname) (show port) + networkconnection <- newNetworkConnection userid serverid (show hostname) clientport let newnetworkconnectionmap = Map.insert userid networkconnection networkconnectionmap MVar.putMVar mvar newnetworkconnectionmap NC.sendMessage (Introduce serverid) hdl -- Answer with own serverid diff --git a/src/Parsing/Grammar.y b/src/Parsing/Grammar.y index 2c65dde..7a32f7e 100644 --- a/src/Parsing/Grammar.y +++ b/src/Parsing/Grammar.y @@ -170,7 +170,8 @@ Exp : let var '=' Exp in Exp %prec LET { Let $2 $4 $6 } | send Exp %prec send { Send $2 } | recv Exp %prec recv { Recv $2 } | create Exp %prec create { Create $2 } - | connect Exp Exp Typ %prec connect { Connect $2 $3 $4} +-- | connect Exp Exp Exp Typ %prec connect { Connect $2 $3 $4 $5 } + | connect Exp Typ Exp Exp %prec connect { Connect $2 $4 $5 $3} | accept Exp Typ %prec accept { Accept $2 $3 } | Exp Exp %prec APP { App $1 $2 } diff --git a/src/PrettySyntax.hs b/src/PrettySyntax.hs index dfa4849..ba68d61 100644 --- a/src/PrettySyntax.hs +++ b/src/PrettySyntax.hs @@ -125,7 +125,7 @@ instance Pretty Exp where pretty (Send e) = pretty "send" <+> pretty e pretty (Recv e) = pretty "recv" <+> pretty e pretty (Create i) = pretty "create" <+> pretty i - pretty (Connect a i t) = pretty "connect" <+> pretty a <+> pretty i <+> pretty t + pretty (Connect s a i t) = pretty "connect" <+> pretty s <+> pretty a <+> pretty i <+> pretty t pretty (Accept s t) = pretty "accept" <+> pretty s <+> pretty t pretty (Case e ses) = pcase e ses diff --git a/src/Syntax.hs b/src/Syntax.hs index 4c5df4d..2cabb29 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -34,7 +34,7 @@ data Exp = Let Ident Exp Exp | Cast Exp Type Type -- New types | Create Exp -- Create Port - | Connect Exp Exp Type -- Connect URL Port Type + | Connect Exp Exp Exp Type -- Connect URL Port Type | Accept Exp Type -- Accept Socket Type deriving (Show,Eq) @@ -171,7 +171,7 @@ instance Freevars Exp where fv (Send e1) = fv e1 fv (Recv e1) = fv e1 fv (Create e1) = fv e1 - fv (Connect e1 e2 ty) = fv e1 <> fv e2 <> fv ty + fv (Connect e0 e1 e2 ty) = fv e0 <>fv e1 <> fv e2 <> fv ty fv (Accept e1 ty) = fv e1 <> fv ty fv (Case e cases) = foldl' (<>) (fv e) $ map (fv . snd) cases fv (Cast e t1 t2) = fv e @@ -240,7 +240,7 @@ instance Substitution Exp where sb (Send e1) = Send (sb e1) sb (Recv e1) = Recv (sb e1) sb (Create e1) = Create (sb e1) - sb (Connect e1 e2 t) = Connect (sb e1) (sb e2) t + sb (Connect e0 e1 e2 t) = Connect (sb e0) (sb e1) (sb e2) t sb (Accept e1 t) = Accept (sb e1) t sb (Succ e1) = Succ (sb e1) sb (NatRec e ez y t z tyz es) = diff --git a/src/TCTyping.hs b/src/TCTyping.hs index 7a2693a..bac4d89 100644 --- a/src/TCTyping.hs +++ b/src/TCTyping.hs @@ -245,7 +245,7 @@ tySynth te e = -- I've got no real clue of what I am doing here hope it kind of works Create e1 -> do return (TServerSocket, te) - Connect e1 e2 ty -> do + Connect e0 e1 e2 ty -> do kiCheck (demoteTE te) ty Kssn return (ty, te) Accept e1 ty -> do From 4db4afabd2de988f1bb63e09d7fec82b6bfdeb25 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 6 Dec 2022 20:15:34 +0100 Subject: [PATCH 042/229] Cleaned up code --- src/Interpreter.hs | 2 +- src/Networking/Client.hs | 6 +++--- src/Networking/Common.hs | 5 +++-- src/Networking/Serialize.hs | 2 +- src/Parsing/Grammar.y | 3 ++- src/PrettySyntax.hs | 2 +- src/Syntax.hs | 6 +++--- src/TCTyping.hs | 2 +- 8 files changed, 15 insertions(+), 13 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 90fcab6..c570e5e 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -207,7 +207,7 @@ eval = \case return $ VChan $ CommunicationChannel (ciReadChannel clientuser) (ciWriteChannel clientuser) (Just newuser) (Just serverid) channelstate _ -> throw $ NotAnExpectedValueException "VServerSocket" val - Connect e0 e1 e2 t -> do + Connect e0 t e1 e2-> do r <- liftIO DC.newConnection w <- liftIO DC.newConnection liftIO $ C.traceIO "Client trying to connect" diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 56e27b1..8c3f01a 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -26,7 +26,7 @@ sendMessage networkconnection val = do case connectionstate of NCon.Connected hostname port -> do addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port - clientsocket <- NC.openSocket $ head addrInfo + clientsocket <- NC.openSocketNC $ head addrInfo connect clientsocket $ addrAddress $ head addrInfo handle <- NC.getHandle clientsocket putStrLn "Client connected: Sending Message" @@ -46,7 +46,7 @@ initialConnect mvar hostname port = do } networkconnectionmap <- MVar.takeMVar mvar addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port - clientsocket <- NC.openSocket $ head addrInfo + clientsocket <- NC.openSocketNC $ head addrInfo connect clientsocket $ addrAddress $ head addrInfo handle <- NC.getHandle clientsocket ownuserid <- UserID.newRandomUserID @@ -60,5 +60,5 @@ initialConnect mvar hostname port = do let newNetworkconnectionmap = Map.insert introductionanswer newConnection networkconnectionmap MVar.putMVar mvar newNetworkconnectionmap - +-- openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 3106049..b966aa6 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -174,7 +174,7 @@ getVChanFromSerial msgRead readCount msgWrite writeCount partnerID ownID port ho putStrLn $ "getVChanFromSerial: Trying to connect to new partner: " ++ hostname ++ ":" ++ port addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port - clientsocket <- openSocket $ head addrInfo + clientsocket <- openSocketNC $ head addrInfo putStrLn "getVChanFromSerial: Aquired socket" connect clientsocket $ addrAddress $ head addrInfo putStrLn "getVChanFromSerial: Connected to socket" @@ -196,4 +196,5 @@ getVChanFromSerial msgRead readCount msgWrite writeCount partnerID ownID port ho return $ VChan $ CommunicationChannel readDC writeDC (Just partnerID) (Just ownID) channelstate -openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) \ No newline at end of file +-- openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) +openSocketNC addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) \ No newline at end of file diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index ba34636..7cc5e7e 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -148,7 +148,7 @@ instance Serializable Exp where Cast e t1 t2 -> serializeLabeledEntryMulti "ECast" e $ sNext t1 $ sLast t2 Create e -> serializeLabeledEntry "ECreate" e - Connect e0 e1 e2 t -> serializeLabeledEntryMulti "EConnect" e0 $ sNext e1 $ sNext e2 $ sLast t + Connect e0 t e1 e2 -> serializeLabeledEntryMulti "EConnect" e0 $ sNext t $ sNext e1 $ sLast e2 Accept e t -> serializeLabeledEntryMulti "EAccept" e $ sLast t instance Serializable (MathOp Exp) where diff --git a/src/Parsing/Grammar.y b/src/Parsing/Grammar.y index 7a32f7e..49af4f3 100644 --- a/src/Parsing/Grammar.y +++ b/src/Parsing/Grammar.y @@ -171,7 +171,8 @@ Exp : let var '=' Exp in Exp %prec LET { Let $2 $4 $6 } | recv Exp %prec recv { Recv $2 } | create Exp %prec create { Create $2 } -- | connect Exp Exp Exp Typ %prec connect { Connect $2 $3 $4 $5 } - | connect Exp Typ Exp Exp %prec connect { Connect $2 $4 $5 $3} +-- | connect Exp Typ Exp Exp %prec connect { Connect $2 $4 $5 $3} + | connect Exp Typ Exp Exp %prec connect {Connect $2 $3 $4 $5} | accept Exp Typ %prec accept { Accept $2 $3 } | Exp Exp %prec APP { App $1 $2 } diff --git a/src/PrettySyntax.hs b/src/PrettySyntax.hs index ba68d61..2941079 100644 --- a/src/PrettySyntax.hs +++ b/src/PrettySyntax.hs @@ -125,7 +125,7 @@ instance Pretty Exp where pretty (Send e) = pretty "send" <+> pretty e pretty (Recv e) = pretty "recv" <+> pretty e pretty (Create i) = pretty "create" <+> pretty i - pretty (Connect s a i t) = pretty "connect" <+> pretty s <+> pretty a <+> pretty i <+> pretty t + pretty (Connect s t a i) = pretty "connect" <+> pretty s <+> pretty t <+> pretty a <+> pretty i pretty (Accept s t) = pretty "accept" <+> pretty s <+> pretty t pretty (Case e ses) = pcase e ses diff --git a/src/Syntax.hs b/src/Syntax.hs index 2cabb29..0a668f6 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -34,7 +34,7 @@ data Exp = Let Ident Exp Exp | Cast Exp Type Type -- New types | Create Exp -- Create Port - | Connect Exp Exp Exp Type -- Connect URL Port Type + | Connect Exp Type Exp Exp -- Connect URL Port Type | Accept Exp Type -- Accept Socket Type deriving (Show,Eq) @@ -171,7 +171,7 @@ instance Freevars Exp where fv (Send e1) = fv e1 fv (Recv e1) = fv e1 fv (Create e1) = fv e1 - fv (Connect e0 e1 e2 ty) = fv e0 <>fv e1 <> fv e2 <> fv ty + fv (Connect e0 ty e1 e2) = fv e0 <> fv ty <>fv e1 <> fv e2 fv (Accept e1 ty) = fv e1 <> fv ty fv (Case e cases) = foldl' (<>) (fv e) $ map (fv . snd) cases fv (Cast e t1 t2) = fv e @@ -240,7 +240,7 @@ instance Substitution Exp where sb (Send e1) = Send (sb e1) sb (Recv e1) = Recv (sb e1) sb (Create e1) = Create (sb e1) - sb (Connect e0 e1 e2 t) = Connect (sb e0) (sb e1) (sb e2) t + sb (Connect e0 t e1 e2) = Connect (sb e0) t (sb e1) (sb e2) sb (Accept e1 t) = Accept (sb e1) t sb (Succ e1) = Succ (sb e1) sb (NatRec e ez y t z tyz es) = diff --git a/src/TCTyping.hs b/src/TCTyping.hs index bac4d89..24cc3c1 100644 --- a/src/TCTyping.hs +++ b/src/TCTyping.hs @@ -245,7 +245,7 @@ tySynth te e = -- I've got no real clue of what I am doing here hope it kind of works Create e1 -> do return (TServerSocket, te) - Connect e0 e1 e2 ty -> do + Connect e0 ty e1 e2 -> do kiCheck (demoteTE te) ty Kssn return (ty, te) Accept e1 ty -> do From a891bc9e0a9d5c86e8c846b3297f757cd01618c7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 7 Dec 2022 14:26:30 +0100 Subject: [PATCH 043/229] Update Client.hs --- src/Networking/Client.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 8c3f01a..e6224f7 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -38,8 +38,8 @@ sendMessage networkconnection val = do MVar.putMVar (ncConnectionState networkconnection) connectionstate -initialConnect :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> IO () -initialConnect mvar hostname port = do +initialConnect :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> Int -> IO () +initialConnect mvar hostname port ownport= do let hints = defaultHints { addrFlags = [] , addrSocketType = Stream @@ -51,7 +51,7 @@ initialConnect mvar hostname port = do handle <- NC.getHandle clientsocket ownuserid <- UserID.newRandomUserID putStrLn "Client connected: Introducing" - NC.sendMessage (Messages.Introduce ownuserid) handle + NC.sendMessage (Messages.IntroduceClient ownuserid $ show ownport) handle introductionanswer <- NC.waitForServerIntroduction handle putStrLn "Finished Handshake" hClose handle From c47b037856916105170354f3d59e7fbb78bbe187 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 7 Dec 2022 15:24:56 +0100 Subject: [PATCH 044/229] made NetworkConnection serializable --- src/Networking/DirectionalConnection.hs | 8 ++++++- src/Networking/Serialize.hs | 31 ++++++++++++++++++++++++- 2 files changed, 37 insertions(+), 2 deletions(-) diff --git a/src/Networking/DirectionalConnection.hs b/src/Networking/DirectionalConnection.hs index 665ab27..e2fbf7d 100644 --- a/src/Networking/DirectionalConnection.hs +++ b/src/Networking/DirectionalConnection.hs @@ -1,4 +1,4 @@ -module Networking.DirectionalConnection (DirectionalConnection(..), newConnection, createConnection, writeMessage, allMessages, readUnreadMessage, readUnreadMessageMaybe) where +module Networking.DirectionalConnection (DirectionalConnection(..), newConnection, createConnection, writeMessage, allMessages, readUnreadMessage, readUnreadMessageMaybe, serializeConnection) where import Control.Concurrent.MVar @@ -49,6 +49,12 @@ readUnreadMessage connection = do Just val -> return val +serializeConnection :: DirectionalConnection a -> IO ([a], Int) +serializeConnection connection = do + messageList <- allMessages connection + messageUnread <- readMVar $ messagesUnreadStart connection + return (messageList, messageUnread) + test = do mycon <- newConnection writeMessage mycon "a" diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index 7cc5e7e..5f35754 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -16,10 +16,12 @@ import Control.Exception import ProcessEnvironment import Networking.Messages import qualified Networking.DirectionalConnection as DC -import qualified Networking.DirectionalConnection as DC +import qualified Networking.NetworkConnection as NCon import qualified Data.Maybe import qualified Data.Map as Map import qualified Network.Socket as Sock +import qualified Data.ByteString as DC +import qualified Networking.DirectionalConnection as NCon newtype SerializationException = UnserializableException String @@ -45,6 +47,32 @@ instance Serializable Messages where RequestSync p -> serializeLabeledEntry "NRequestSync" p ChangePartnerAddress p h port -> serializeLabeledEntryMulti "NChangePartnerAddress" p $ sNext h $ sLast port +-- instance (Serializable a => Serializable (NCon.NetworkConnection a)) where +instance Serializable (NCon.NetworkConnection Value) where + serialize con = do + constate <- MVar.takeMVar $ NCon.ncConnectionState con + (readList, readUnread) <- DC.serializeConnection $ NCon.ncRead con + (writeList, writeUnread) <- DC.serializeConnection $ NCon.ncWrite con + + + serializeLabeledEntryMulti "NNetworkConnection" (NCon.ncRead con) $ sNext (NCon.ncWrite con) $ sNext (Data.Maybe.fromMaybe "" $ NCon.ncPartnerUserID con) $ sNext (Data.Maybe.fromMaybe "" $ NCon.ncOwnUserID con) $ sLast constate + + +-- instance (Serializable a => Serializable (NCon.DirectionalConnection a)) where +instance Serializable (NCon.DirectionalConnection Value) where + serialize dcon = do + (msg, msgUnread) <- DC.serializeConnection dcon + + serializeLabeledEntryMulti "NDirectionalConnection" msg $ sLast msgUnread + + +instance Serializable NCon.ConnectionState where + serialize = \case + NCon.Connected hostname port -> serializeLabeledEntryMulti "NConnected" hostname $ sLast port + NCon.Disconnected -> return "NDisconnected" + NCon.Emulated -> return "NEmulated" + + instance Serializable Value where serialize = \case VUnit -> return "VUnit" @@ -259,6 +287,7 @@ instance {-# OVERLAPPING #-}Serializable [Value] where serialize arr = serializeLabeledArray "SValuesArray" arr + instance Serializable (Chan.Chan Value) where serialize c = do ccnt <- getChanContents c From ef8e344df092957dcbab1e824c8a080401c98ee4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 7 Dec 2022 18:46:53 +0100 Subject: [PATCH 045/229] New communication protocol Introduced a new communication protocol where sending VChans should be easier --- src/Interpreter.hs | 128 +++++++++++++++++----------- src/Networking/Client.hs | 5 +- src/Networking/Common.hs | 7 +- src/Networking/NetworkConnection.hs | 9 +- src/Networking/Serialize.hs | 5 +- src/Networking/Server.hs | 5 +- src/PrettySyntax.hs | 2 +- src/ProcessEnvironment.hs | 41 +++++++-- src/ValueParsing/ValueGrammar.y | 6 +- src/ValueParsing/ValueTokens.x | 4 + 10 files changed, 144 insertions(+), 68 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index c570e5e..ef65262 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -30,6 +30,7 @@ import qualified SerializeValues as SV import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG import qualified Networking.Common as NC +import qualified Networking.Client as NClient import Network.Run.TCP import qualified Networking.Server as NS @@ -41,8 +42,11 @@ import qualified Networking.UserID as UserID import qualified Networking.Messages as Messages import qualified Networking.DirectionalConnection as DC +import qualified Networking.NetworkConnection as NCon import ProcessEnvironment (CommunicationChannel(CommunicationChannel, ccChannelState, ccPartnerUserID), ConnectionInfo (ciReadChannel, ciWriteChannel)) import qualified Control.Concurrent as MVar +import qualified Networking.NetworkConnection as NCon +import qualified Networking.NetworkConnection as NCon data InterpreterException = MathException String @@ -55,6 +59,7 @@ data InterpreterException | TypeNotImplementedException Type | DeserializationException String | NotAnExpectedValueException String Value + | CommunicationPartnerNotFoundException String deriving Eq instance Show InterpreterException where @@ -69,6 +74,7 @@ instance Show InterpreterException where (TypeNotImplementedException typ) -> "TypeNotImplementedException: " ++ pshow typ (DeserializationException err) -> "DeserializationException: " ++ err (NotAnExpectedValueException expected val) -> "NotAnExpectedValueException: This expresion: (" ++ pshow val ++ ") is not of type: " ++ expected + (CommunicationPartnerNotFoundException partner) -> "CommunicationPartnerNotFoundException: Partner:" ++ partner ++ " not found" instance Exception InterpreterException @@ -163,15 +169,19 @@ eval = \case -- return $ VPair (VChan r w Nothing Nothing Nothing Nothing) (VChan w r Nothing Nothing Nothing Nothing) r <- liftIO DC.newConnection w <- liftIO DC.newConnection - channelstate1 <- liftIO MVar.newEmptyMVar + {-channelstate1 <- liftIO MVar.newEmptyMVar liftIO $ MVar.putMVar channelstate1 Emulated channelstate2 <- liftIO MVar.newEmptyMVar liftIO $ MVar.putMVar channelstate2 Emulated - return $ VPair (VChan (CommunicationChannel r w Nothing Nothing channelstate1)) (VChan (CommunicationChannel w r Nothing Nothing channelstate2)) + return $ VPair (VChan (CommunicationChannel r w Nothing Nothing channelstate1)) (VChan (CommunicationChannel w r Nothing Nothing channelstate2))-} + nc1 <- liftIO $ NCon.newEmulatedConnection r w + nc2 <- liftIO $ NCon.newEmulatedConnection w r + return $ VPair (VChan nc1) $ VChan nc2 Send e -> VSend <$> interpret' e -- Apply VSend to the output of interpret' e Recv e -> do interpret' e >>= \v@(VChan ci) -> do - let dcRead = ccRead ci + -- let dcRead = ccRead ci + let dcRead = NCon.ncRead ci -- val <- liftIO $ Chan.readChan c val <- liftIO $ DC.readUnreadMessage dcRead @@ -179,16 +189,16 @@ eval = \case return $ VPair val v Case e cases -> interpret' e >>= \(VLabel s) -> interpret' $ fromJust $ lookup s cases Create e -> do - liftIO $ C.traceIO "Creating server!" + liftIO $ C.traceIO "Creating socket!" val <- interpret' e case val of VInt port -> do -- mvar <- liftIO MVar.newEmptyMVar - (mvar, chan, serverid) <- liftIO $ NS.createServer port - liftIO $ C.traceIO "Server created" + (mvar, chan) <- liftIO $ NS.createServerNew port + liftIO $ C.traceIO "Socket created" -- return $ VServerSocket mvar - return $ VServerSocket mvar chan serverid + return $ VServerSocket mvar chan $ show port _ -> throw $ NotAnExpectedValueException "VInt" val Accept e t -> do @@ -196,15 +206,19 @@ eval = \case val <- interpret' e case val of - VServerSocket mvar chan serverid -> do + VServerSocket mvar chan ownport -> do -- socket <- liftIO $ MVar.readMVar socketMVar newuser <- liftIO $ Chan.readChan chan - clientuser <- liftIO $ NC.getConnectionInfo mvar newuser + -- clientuser <- liftIO $ NC.getConnectionInfo mvar newuser liftIO $ C.traceIO "Client accepted" -- return $ VChan (ciReadChannel clientuser) (ciWriteChannel clientuser) (Just $ ciHandle clientuser ) (Just $ ciAddr clientuser ) (Just newuser) $ Just serverid - channelstate <- liftIO MVar.newEmptyMVar - liftIO $ MVar.putMVar channelstate $ Connected mvar - return $ VChan $ CommunicationChannel (ciReadChannel clientuser) (ciWriteChannel clientuser) (Just newuser) (Just serverid) channelstate + -- channelstate <- liftIO MVar.newEmptyMVar + -- liftIO $ MVar.putMVar channelstate $ Connected mvar + -- return $ VChan $ CommunicationChannel (ciReadChannel clientuser) (ciWriteChannel clientuser) (Just newuser) (Just serverid) channelstate + networkconnectionmap <- liftIO $ MVar.readMVar mvar + case Map.lookup newuser networkconnectionmap of + Nothing -> throw $ CommunicationPartnerNotFoundException newuser + Just networkconnection -> return $ VChan networkconnection _ -> throw $ NotAnExpectedValueException "VServerSocket" val Connect e0 t e1 e2-> do @@ -212,46 +226,53 @@ eval = \case w <- liftIO DC.newConnection liftIO $ C.traceIO "Client trying to connect" - addressVal <- interpret' e1 - case addressVal of - VString address -> do - portVal <- interpret' e2 - case portVal of - VInt port -> do - -- socketmvar <- liftIO newEmptyMVar - -- liftIO $ forkIO $ runTCPClient address (show port) $ putMVar socketmvar - -- socket <- liftIO $ readMVar socketmvar - -- liftIO $ forkIO $ NC.communicate r w socket - -- liftIO $ forkIO $ runTCPClient address (show port) (NC.communicate r w) - let hints = defaultHints { - addrFlags = [] - , addrSocketType = Stream - } - addrInfo <- liftIO $ getAddrInfo (Just hints) (Just address) $ Just $ show port - clientsocket <- liftIO $ openSocket $ head addrInfo - liftIO $ connect clientsocket $ addrAddress $ head addrInfo - -- liftIO $ forkIO $ NC.communicate r w clientsocket - handle <- liftIO $ NC.getHandle clientsocket - liftIO $ C.traceIO "Client connected" - ownuserid <- liftIO UserID.newRandomUserID - liftIO $ NC.sendMessage (Messages.Introduce ownuserid) handle - - -- Wait for answer from the server - serverid <- liftIO $ NC.waitForServerIntroduction handle - - -- Hockup automatic message recieving - mvar <- liftIO MVar.newEmptyMVar - liftIO $ MVar.putMVar mvar (Map.fromList [(serverid, ConnectionInfo handle (addrAddress $ head addrInfo) r w )]) - liftIO $ forkIO $ NC.recieveMessagesID r mvar serverid - - - -- return $ VChan r w (Just handle) (Just $ addrAddress $ head addrInfo) (Just serverid) $ Just ownuserid - channelstate <- liftIO MVar.newEmptyMVar - liftIO $ MVar.putMVar channelstate $ Connected mvar - - return $ VChan $ CommunicationChannel r w (Just serverid) (Just ownuserid) channelstate - _ -> throw $ NotAnExpectedValueException "VInt" portVal - _ -> throw $ NotAnExpectedValueException "VString" addressVal + serversocket <- interpret' e0 + case serversocket of + VServerSocket networkconmapmvar chan ownport -> do + addressVal <- interpret' e1 + case addressVal of + VString address -> do + portVal <- interpret' e2 + case portVal of + VInt port -> do + liftIO $ NClient.initialConnect networkconmapmvar address (show port) ownport + {- + -- socketmvar <- liftIO newEmptyMVar + -- liftIO $ forkIO $ runTCPClient address (show port) $ putMVar socketmvar + -- socket <- liftIO $ readMVar socketmvar + -- liftIO $ forkIO $ NC.communicate r w socket + -- liftIO $ forkIO $ runTCPClient address (show port) (NC.communicate r w) + let hints = defaultHints { + addrFlags = [] + , addrSocketType = Stream + } + addrInfo <- liftIO $ getAddrInfo (Just hints) (Just address) $ Just $ show port + clientsocket <- liftIO $ openSocket $ head addrInfo + liftIO $ connect clientsocket $ addrAddress $ head addrInfo + -- liftIO $ forkIO $ NC.communicate r w clientsocket + handle <- liftIO $ NC.getHandle clientsocket + liftIO $ C.traceIO "Client connected" + ownuserid <- liftIO UserID.newRandomUserID + liftIO $ NC.sendMessage (Messages.Introduce ownuserid) handle + + -- Wait for answer from the server + serverid <- liftIO $ NC.waitForServerIntroduction handle + + -- Hockup automatic message recieving + mvar <- liftIO MVar.newEmptyMVar + liftIO $ MVar.putMVar mvar (Map.fromList [(serverid, ConnectionInfo handle (addrAddress $ head addrInfo) r w )]) + liftIO $ forkIO $ NC.recieveMessagesID r mvar serverid + + + -- return $ VChan r w (Just handle) (Just $ addrAddress $ head addrInfo) (Just serverid) $ Just ownuserid + channelstate <- liftIO MVar.newEmptyMVar + liftIO $ MVar.putMVar channelstate $ Connected mvar + + return $ VChan $ CommunicationChannel r w (Just serverid) (Just ownuserid) channelstate + -} + _ -> throw $ NotAnExpectedValueException "VInt" portVal + _ -> throw $ NotAnExpectedValueException "VString" addressVal + _ -> throw $ NotAnExpectedValueException "VServerSocket" serversocket where openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) e -> throw $ NotImplementedException e @@ -289,7 +310,9 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) R.local (const env') (interpret' es) -- interpretApp _ (VSend v@(VChan _ c handle _ _ _)) w = do interpretApp _ (VSend v@(VChan cc)) w = do + liftIO $ NClient.sendMessage cc w -- liftIO (Chan.writeChan c w) + {- liftIO $ DC.writeMessage (ccWrite cc) w channelstate <- liftIO $ MVar.readMVar (ccChannelState cc) case ccPartnerUserID cc of @@ -300,6 +323,7 @@ interpretApp _ (VSend v@(VChan cc)) w = do --case handle of -- Nothing -> pure () -- Just hdl -> liftIO $ NC.sendMessage w hdl + -} return v interpretApp e _ _ = throw $ ApplicationException e diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index e6224f7..790f51d 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -38,7 +38,7 @@ sendMessage networkconnection val = do MVar.putMVar (ncConnectionState networkconnection) connectionstate -initialConnect :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> Int -> IO () +initialConnect :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> IO Value initialConnect mvar hostname port ownport= do let hints = defaultHints { addrFlags = [] @@ -51,7 +51,7 @@ initialConnect mvar hostname port ownport= do handle <- NC.getHandle clientsocket ownuserid <- UserID.newRandomUserID putStrLn "Client connected: Introducing" - NC.sendMessage (Messages.IntroduceClient ownuserid $ show ownport) handle + NC.sendMessage (Messages.IntroduceClient ownuserid ownport) handle introductionanswer <- NC.waitForServerIntroduction handle putStrLn "Finished Handshake" hClose handle @@ -59,6 +59,7 @@ initialConnect mvar hostname port ownport= do newConnection <- newNetworkConnection introductionanswer ownuserid hostname port let newNetworkconnectionmap = Map.insert introductionanswer newConnection networkconnectionmap MVar.putMVar mvar newNetworkconnectionmap + return $ VChan newConnection -- openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index b966aa6..f5d0fca 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -70,8 +70,9 @@ recieveMessagesID chan mvar userid = do Left err -> putStrLn $ "Error during recieving a networkmessage: "++err Right deserialmessages -> case deserialmessages of NewValue userid val -> do - valCleaned <- replaceVChanSerial val -- Replaces VChanSerial with VChans and their appropriate connection - DC.writeMessage chan valCleaned + -- valCleaned <- replaceVChanSerial val -- Replaces VChanSerial with VChans and their appropriate connection + -- DC.writeMessage chan valCleaned + DC.writeMessage chan val _ -> do serial <- NSerialize.serialize deserialmessages putStrLn $ "Error unsupported networkmessage: "++ serial @@ -124,6 +125,7 @@ waitForServerIntroduction handle = do throw $ NoIntroductionException message +{- replaceVChanSerial :: Value -> IO Value replaceVChanSerial input = case input of VSend v -> do @@ -195,6 +197,7 @@ getVChanFromSerial msgRead readCount msgWrite writeCount partnerID ownID port ho else MVar.putMVar channelstate Disconnected return $ VChan $ CommunicationChannel readDC writeDC (Just partnerID) (Just ownID) channelstate +-} -- openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) openSocketNC addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) \ No newline at end of file diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index b89041a..2e76f1a 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -18,4 +18,11 @@ newNetworkConnection partnerID ownID hostname port = do write <- newConnection connectionstate <- MVar.newEmptyMVar MVar.putMVar connectionstate $ Connected hostname port - return $ NetworkConnection read write (Just partnerID) (Just ownID) connectionstate \ No newline at end of file + return $ NetworkConnection read write (Just partnerID) (Just ownID) connectionstate + + +newEmulatedConnection :: DirectionalConnection a -> DirectionalConnection a -> IO (NetworkConnection a) +newEmulatedConnection r w = do + connectionstate <- MVar.newEmptyMVar + MVar.putMVar connectionstate Emulated + return $ NetworkConnection r w Nothing Nothing connectionstate \ No newline at end of file diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index 5f35754..b3e7070 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -90,8 +90,9 @@ instance Serializable Value where VNewNatRec env f n tid ty ez x es -> serializeLabeledEntryMulti "VNewNatRec" env $ sNext f $ sNext n $ sNext tid $ sNext ty $ sNext ez $ sNext x $ sLast es VServerSocket {} -> throw $ UnserializableException "VServerSocket" + VChan nc -> serializeLabeledEntry "VChan" nc -- VChan {} -> throw $ UnserializableException "VChan" - VChan cc -> do + {-VChan cc -> do putStrLn "Trying to serialize VChan" channelstate <- MVar.readMVar (ccChannelState cc) case channelstate of @@ -120,7 +121,7 @@ instance Serializable Value where case ciAddr connectioninfo of Sock.SockAddrInet port hostname -> serializeLabeledEntryMulti "VChan" readList $ sNext readStartUnread $ sNext writeList $ sNext writeStartUnread $ sNext partnerUserID $ sNext ownUserID $ sNext (show port) $ sLast (show hostname) _ -> throw $ UnserializableException "VChan currently only works over IPv4" - _ -> throw $ UnserializableException "VChan can only be serialized when in Connected mode" + _ -> throw $ UnserializableException "VChan can only be serialized when in Connected mode"-} instance Serializable Multiplicity where serialize = \case diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 7662878..6bd50a4 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -88,8 +88,9 @@ acceptClientNew mvar chan clientsocket = do networkconnectionmap <- MVar.takeMVar mvar case Map.lookup userid networkconnectionmap of Just networkconnection -> do -- This means we habe already spoken to this client - valCleaned <- NC.replaceVChanSerial val -- Replaces VChanSerial with VChans and their appropriate connection - ND.writeMessage (ncRead networkconnection) valCleaned + -- valCleaned <- NC.replaceVChanSerial val -- Replaces VChanSerial with VChans and their appropriate connection + -- ND.writeMessage (ncRead networkconnection) valCleaned + ND.writeMessage (ncRead networkconnection) val MVar.putMVar mvar networkconnectionmap Nothing -> do putStrLn "Error during recieving a networkmessage: Introduction is needed prior to sending values!" diff --git a/src/PrettySyntax.hs b/src/PrettySyntax.hs index 2941079..8a1b851 100644 --- a/src/PrettySyntax.hs +++ b/src/PrettySyntax.hs @@ -169,7 +169,7 @@ instance Pretty Value where VDouble d -> pretty $ show d VString s -> pretty $ show s VChan {} -> pretty "VChan" - VChanSerial {} -> pretty "VChanSerial" + -- VChanSerial {} -> pretty "VChanSerial" VSend v -> pretty "VSend" VPair a b -> pretty "<" <+> pretty a <+> pretty ", " <+> pretty b <+> pretty ">" VType t -> pretty t diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index b4cac23..9470327 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -12,9 +12,11 @@ import qualified Data.Set as Set import Kinds (Multiplicity(..)) import Networking.DirectionalConnection +import qualified Networking.NetworkConnection as NCon -- import qualified Networking.Common as NC import Network.Socket +import qualified Networking.NetworkConnection as NCon -- import qualified Networking.Common as NC -- | the interpretation monad @@ -52,8 +54,9 @@ data Value -- we have two channels, one for reading and one for writing to the other -- end, so we do not read our own written values -- | VChan (C.Chan Value) (C.Chan Value) (Maybe Handle) (Maybe SockAddr) (Maybe String) (Maybe String) - | VChan CommunicationChannel - | VChanSerial [Value] Int [Value] Int String String String String + -- | VChan CommunicationChannel + | VChan (NCon.NetworkConnection Value) + -- | VChanSerial [Value] Int [Value] Int String String String String -- Maybe replace this with an VChan Either comchan or this -- Read Chan Write Chan Handle of Con Address of other other Userid own UserID -- | VChan (C.Chan Value) (C.Chan Value) @@ -67,8 +70,8 @@ data Value | VNewNatRec PEnv String String String Type Exp String Exp -- | VServerSocket (MVar.MVar Socket) -- | VServerSocket Socket - | VServerSocket (MVar.MVar (Map.Map String ConnectionInfo)) (C.Chan String) String - -- This is the server id + | VServerSocket (MVar.MVar (Map.Map String (NCon.NetworkConnection Value))) (C.Chan String) String + -- Own Port Number deriving Eq @@ -88,6 +91,29 @@ data ChannelState = Connected {csConInfoMap :: MVar.MVar (Map.Map String Connect -- If a channel is about to be send it should be deactivated +disableVChan :: Value -> IO () +disableVChan = \case + VSend v -> disableVChan v + VPair v1 v2 -> disableVChan v1 >> disableVChan v2 + VFunc penv _ _ -> disableVChanArr penv + VDynCast v _ -> disableVChan v + VFuncCast v _ _ -> disableVChan v + VRec penv _ _ _ _ -> disableVChanArr penv + VNewNatRec penv _ _ _ _ _ _ _ -> disableVChanArr penv + VChan cc -> do + channelstate <- MVar.takeMVar $ NCon.ncConnectionState cc + case channelstate of + NCon.Connected {} -> MVar.putMVar (NCon.ncConnectionState cc) NCon.Disconnected + _ -> MVar.putMVar (NCon.ncConnectionState cc) channelstate + _ -> return () + where + disableVChanArr :: PEnv -> IO () + disableVChanArr [] = return () + disableVChanArr (x:xs) = disableVChan (snd x) >> disableVChanArr xs + + +{- + disableVChan :: Value -> IO () disableVChan = \case VSend v -> disableVChan v @@ -111,6 +137,11 @@ disableVChan = \case +-} + + + + instance Show Value where show = \case @@ -120,7 +151,7 @@ instance Show Value where VDouble d -> "VDouble " ++ show d VString s -> "VString \"" ++ show s ++ "\"" VChan {} -> "VChan" - VChanSerial {} -> "VChanSerial" + -- VChanSerial {} -> "VChanSerial" VSend v -> "VSend (" ++ show v ++ ")" VPair a b -> "VPair <" ++ show a ++ ", " ++ show b ++ ">" VType t -> "VType " ++ show t diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index e70015b..6c7d882 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -109,6 +109,8 @@ import Networking.Messages svaluesarray { T _ T.SValuesArray } nintroduce { T _ T.NIntroduce } + nintroduceclient { T _ T.NIntroduceClient } + nintroduceserver { T _ T.NIntroduceServer } nnewvalue { T _ T.NNewValue } nsyncincoming { T _ T.NSyncIncoming } nrequestsync { T _ T.NRequestSync } @@ -171,7 +173,7 @@ Values : vunit { VUnit } | vint '(' int ')' {VInt $3} | vdouble '(' double ')' {VDouble $3} | vstring '(' String ')' {VString $3 } - | vchan '(' SValuesArray ')' '(' int ')' '(' SValuesArray ')' '(' int ')' '(' String ')' '(' String ')' '(' String ')' '(' String ')' {VChanSerial $3 $6 $9 $12 $15 $18 $21 $24 } + -- | vchan '(' SValuesArray ')' '(' int ')' '(' SValuesArray ')' '(' int ')' '(' String ')' '(' String ')' '(' String ')' '(' String ')' {VChanSerial $3 $6 $9 $12 $15 $18 $21 $24 } | vsend '(' Values ')' {VSend $3} | vpair '(' Values ')' '(' Values ')' {VPair $3 $6} | vtype '(' Type ')' {VType $3} @@ -256,6 +258,8 @@ GType : gunit {GUnit} | gstring {GString} Messages : nintroduce '(' String ')' {Introduce $3} + | nintroduceclient '(' String ')' '(' String ')' {IntroduceClient $3 $6} + | nintroduceserver '(' String ')' {IntroduceServer $3} | nnewvalue '(' String ')''(' Values ')' {NewValue $3 $6} | nsyncincoming '(' String ')''(' SValuesArray ')' {SyncIncoming $3 $6} | nrequestsync '(' String ')' {RequestSync $3} diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index af31d4c..8dce9e1 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -124,6 +124,8 @@ tokens :- "SValuesArray" { tok $ const SValuesArray } "NIntroduce" { tok $ const NIntroduce } + "NIntroduceClient" { tok $ const NIntroduceClient } + "NIntroduceServer" { tok $ const NIntroduceServer } "NNewValue" { tok $ const NNewValue } "NSyncIncoming" { tok $ const NSyncIncoming } "NRequestSync" { tok $ const NRequestSync } @@ -237,6 +239,8 @@ data Token | SValuesArray | NIntroduce + | NIntroduceClient + | NIntroduceServer | NNewValue | NSyncIncoming | NRequestSync From 048c203a6b12ffef96aa3305a7659b9688e1ee60 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 7 Dec 2022 19:22:25 +0100 Subject: [PATCH 046/229] Added bidirectional test and fixed a bug associated with it --- dev-examples/bidirectional/client.ldgvnw | 25 +++++++++++++++++++ dev-examples/bidirectional/server.ldgvnw | 25 +++++++++++++++++++ .../{client-new.ldgvnw => client-old.ldgvnw} | 3 +-- dev-examples/simple/client.ldgvnw | 3 ++- src/Interpreter.hs | 1 + src/Networking/Client.hs | 4 +++ src/Networking/Server.hs | 7 +++++- 7 files changed, 64 insertions(+), 4 deletions(-) create mode 100644 dev-examples/bidirectional/client.ldgvnw create mode 100644 dev-examples/bidirectional/server.ldgvnw rename dev-examples/simple/{client-new.ldgvnw => client-old.ldgvnw} (68%) diff --git a/dev-examples/bidirectional/client.ldgvnw b/dev-examples/bidirectional/client.ldgvnw new file mode 100644 index 0000000..b7d7106 --- /dev/null +++ b/dev-examples/bidirectional/client.ldgvnw @@ -0,0 +1,25 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. ?Int. !Int. ?Int. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let = recv x in + let y = ((send x2) 41) in + let = recv y in + (m + n) + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let c22 = (send c2) 1300 in + let = recv c22 in + let c32 = (send c3) 37 in + + (m + n) + +val main : Int +val main = + let sock = (create 4343) in + let con = (connect sock SendInt "127.0.0.1" 4242 ) in -- This cannot be localhost, since this might break on containerized images + send2 con diff --git a/dev-examples/bidirectional/server.ldgvnw b/dev-examples/bidirectional/server.ldgvnw new file mode 100644 index 0000000..19a24a3 --- /dev/null +++ b/dev-examples/bidirectional/server.ldgvnw @@ -0,0 +1,25 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. ?Int. !Int. ?Int. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let = recv x in + let y = ((send x2) 41) in + let = recv y in + (m + n) + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let c22 = (send c2) 1300 in + let = recv c22 in + let c32 = (send c3) 37 in + + (m + n) + +val main : Int +val main = + let sock = (create 4242) in + let con = (accept sock (dualof SendInt)) in + add2 con diff --git a/dev-examples/simple/client-new.ldgvnw b/dev-examples/simple/client-old.ldgvnw similarity index 68% rename from dev-examples/simple/client-new.ldgvnw rename to dev-examples/simple/client-old.ldgvnw index 509798d..7996182 100644 --- a/dev-examples/simple/client-new.ldgvnw +++ b/dev-examples/simple/client-old.ldgvnw @@ -15,6 +15,5 @@ val add2 (c1: dualof SendInt) = val main : Unit val main = - let sock = (create 4343) in - let con = (connect sock SendInt "127.0.0.1" 4242 ) in -- This cannot be localhost, since this might break on containerized images + let con = (connect "127.0.0.1" 4242 SendInt) in -- This cannot be localhost, since this might break on containerized images send2 con diff --git a/dev-examples/simple/client.ldgvnw b/dev-examples/simple/client.ldgvnw index 7996182..509798d 100644 --- a/dev-examples/simple/client.ldgvnw +++ b/dev-examples/simple/client.ldgvnw @@ -15,5 +15,6 @@ val add2 (c1: dualof SendInt) = val main : Unit val main = - let con = (connect "127.0.0.1" 4242 SendInt) in -- This cannot be localhost, since this might break on containerized images + let sock = (create 4343) in + let con = (connect sock SendInt "127.0.0.1" 4242 ) in -- This cannot be localhost, since this might break on containerized images send2 con diff --git a/src/Interpreter.hs b/src/Interpreter.hs index ef65262..cbf6ced 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -310,6 +310,7 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) R.local (const env') (interpret' es) -- interpretApp _ (VSend v@(VChan _ c handle _ _ _)) w = do interpretApp _ (VSend v@(VChan cc)) w = do + liftIO $ putStrLn $ "Trying to send message:" ++ show w liftIO $ NClient.sendMessage cc w -- liftIO (Chan.writeChan c w) {- diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 790f51d..c9de0ae 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -25,9 +25,13 @@ sendMessage networkconnection val = do connectionstate <- MVar.takeMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port -> do + putStrLn $ "Trying to connect to: " ++ hostname ++":"++port addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port + --addrInfo <- getAddrInfo (Just hints) (Just "127.0.0.1") $ Just port -- Thia is obviously only for testing clientsocket <- NC.openSocketNC $ head addrInfo + putStrLn "Before connect" connect clientsocket $ addrAddress $ head addrInfo + putStrLn "After connect" handle <- NC.getHandle clientsocket putStrLn "Client connected: Sending Message" NC.sendMessage (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) val) handle diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 6bd50a4..1fffaba 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -104,7 +104,8 @@ acceptClientNew mvar chan clientsocket = do Nothing -> case snd clientsocket of -- This client is new SockAddrInet port hostname -> do serverid <- UserID.newRandomUserID - networkconnection <- newNetworkConnection userid serverid (show hostname) clientport + -- networkconnection <- newNetworkConnection userid serverid (show hostname) clientport + networkconnection <- newNetworkConnection userid serverid (hostaddressTypeToString hostname) clientport let newnetworkconnectionmap = Map.insert userid networkconnection networkconnectionmap MVar.putMVar mvar newnetworkconnectionmap NC.sendMessage (Introduce serverid) hdl -- Answer with own serverid @@ -131,6 +132,10 @@ acceptClientNew mvar chan clientsocket = do hClose hdl +hostaddressTypeToString :: HostAddress -> String +hostaddressTypeToString hostaddress = do + let (a, b, c, d) = hostAddressToTuple hostaddress + show a ++ "." ++ show b ++ "."++ show c ++ "." ++ show d acceptClients :: MVar.MVar (Map.Map String ConnectionInfo) -> Chan.Chan String -> Socket -> String-> IO () From 3d36f9a49d00c18134cee87f21785b712b36c548 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 7 Dec 2022 19:48:52 +0100 Subject: [PATCH 047/229] fixed the handoff example code --- dev-examples/handoff/client.ldgvnw | 7 ++++--- src/Networking/DirectionalConnection.hs | 1 + src/Networking/NetworkConnection.hs | 10 ++++++++++ 3 files changed, 15 insertions(+), 3 deletions(-) diff --git a/dev-examples/handoff/client.ldgvnw b/dev-examples/handoff/client.ldgvnw index afcf974..3fc0245 100644 --- a/dev-examples/handoff/client.ldgvnw +++ b/dev-examples/handoff/client.ldgvnw @@ -20,8 +20,9 @@ val add2 (c1: dualof SendTwoInt) = val main : Unit val main = - let con = (connect "127.0.0.1" 4242 SendTwoInt) in -- This cannot be localhost, since this might break on containerized images - let oneint = send1 con in - let con2 = (connect "127.0.0.1" 4343 SendSendOneInt) in + let sock = (create 4141) in + let con = (connect sock SendTwoInt "127.0.0.1" 4242) in -- This cannot be localhost, since this might break on containerized images + let oneint = (send1 con) in + let con2 = (connect sock SendSendOneInt "127.0.0.1" 4343) in (send con2) oneint diff --git a/src/Networking/DirectionalConnection.hs b/src/Networking/DirectionalConnection.hs index e2fbf7d..ebb4f04 100644 --- a/src/Networking/DirectionalConnection.hs +++ b/src/Networking/DirectionalConnection.hs @@ -55,6 +55,7 @@ serializeConnection connection = do messageUnread <- readMVar $ messagesUnreadStart connection return (messageList, messageUnread) + test = do mycon <- newConnection writeMessage mycon "a" diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index 2e76f1a..767363a 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -21,6 +21,16 @@ newNetworkConnection partnerID ownID hostname port = do return $ NetworkConnection read write (Just partnerID) (Just ownID) connectionstate +createNetworkConnection :: [a] -> Int -> [a] -> Int -> Maybe String -> Maybe String -> String -> String -> IO (NetworkConnection a) +createNetworkConnection readList readNew writeList writeNew partnerID ownID hostname port = do + read <- createConnection readList readNew + write <- createConnection writeList writeNew + connectionstate <- MVar.newEmptyMVar + MVar.putMVar connectionstate $ Connected hostname port + return $ NetworkConnection read write partnerID ownID connectionstate + + + newEmulatedConnection :: DirectionalConnection a -> DirectionalConnection a -> IO (NetworkConnection a) newEmulatedConnection r w = do connectionstate <- MVar.newEmptyMVar From f90fb5d2b478fd51d769acda4627b78c54aebbe1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 8 Dec 2022 10:42:55 +0100 Subject: [PATCH 048/229] Handoff now works in limited cases --- src/Interpreter.hs | 7 +++-- src/Networking/Common.hs | 43 +++++++++++++++++++++++++++++ src/Networking/NetworkConnection.hs | 3 ++ src/Networking/Serialize.hs | 12 ++++---- src/Networking/Server.hs | 12 ++++---- src/ProcessEnvironment.hs | 5 ++-- src/ValueParsing/ValueGrammar.y | 11 ++++++++ src/ValueParsing/ValueTokens.x | 7 +++++ 8 files changed, 85 insertions(+), 15 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index cbf6ced..caa519c 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -43,10 +43,11 @@ import qualified Networking.UserID as UserID import qualified Networking.Messages as Messages import qualified Networking.DirectionalConnection as DC import qualified Networking.NetworkConnection as NCon -import ProcessEnvironment (CommunicationChannel(CommunicationChannel, ccChannelState, ccPartnerUserID), ConnectionInfo (ciReadChannel, ciWriteChannel)) +-- import ProcessEnvironment (CommunicationChannel(CommunicationChannel, ccChannelState, ccPartnerUserID), ConnectionInfo (ciReadChannel, ciWriteChannel)) +-- import ProcessEnvironment import qualified Control.Concurrent as MVar -import qualified Networking.NetworkConnection as NCon -import qualified Networking.NetworkConnection as NCon +-- import qualified Networking.NetworkConnection as NCon +-- import qualified Networking.NetworkConnection as NCon data InterpreterException = MathException String diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index f5d0fca..e877ba2 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -25,6 +25,7 @@ import qualified ValueParsing.ValueGrammar as VG import qualified Networking.DirectionalConnection as DC import Networking.DirectionalConnection (DirectionalConnection) import Networking.Serialize (Serializable) +import Networking.NetworkConnection (createNetworkConnection, createNetworkConnectionS) newtype ServerException = NoIntroductionException String deriving Eq @@ -36,6 +37,8 @@ instance Show ServerException where instance Exception ServerException +{- + -- Hangs if no valid client id is provided getConnectionInfo :: MVar.MVar (Map String ConnectionInfo) -> String -> IO ConnectionInfo getConnectionInfo mvar user = do @@ -78,6 +81,7 @@ recieveMessagesID chan mvar userid = do putStrLn $ "Error unsupported networkmessage: "++ serial recieveMessagesID chan mvar userid +-} sendMessage :: NSerialize.Serializable a => a -> Handle -> IO () sendMessage value handle = do @@ -125,6 +129,45 @@ waitForServerIntroduction handle = do throw $ NoIntroductionException message +replaceVChanSerial :: Value -> IO Value +replaceVChanSerial input = case input of + VSend v -> do + nv <- replaceVChanSerial v + return $ VSend nv + VPair v1 v2 -> do + nv1 <- replaceVChanSerial v1 + nv2 <- replaceVChanSerial v2 + return $ VPair nv1 nv2 + VFunc penv a b -> do + newpenv <- replaceVChanSerialPEnv penv + return $ VFunc newpenv a b + VDynCast v g -> do + nv <- replaceVChanSerial v + return $ VDynCast nv g + VFuncCast v a b -> do + nv <- replaceVChanSerial v + return $ VFuncCast nv a b + VRec penv a b c d -> do + newpenv <- replaceVChanSerialPEnv penv + return $ VRec newpenv a b c d + VNewNatRec penv a b c d e f g -> do + newpenv <- replaceVChanSerialPEnv penv + return $ VNewNatRec newpenv a b c d e f g + VChanSerial r w p o c -> do + putStrLn "Attempting to deserialize a VChanSerial" + networkconnection <- createNetworkConnectionS r w p o c + return $ VChan networkconnection + _ -> return input + where + replaceVChanSerialPEnv :: [(String, Value)] -> IO [(String, Value)] + replaceVChanSerialPEnv [] = return [] + replaceVChanSerialPEnv (x:xs) = do + newval <- replaceVChanSerial $ snd x + rest <- replaceVChanSerialPEnv xs + return $ (fst x, newval):rest + + + {- replaceVChanSerial :: Value -> IO Value replaceVChanSerial input = case input of diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index 767363a..1f3e81c 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -30,6 +30,9 @@ createNetworkConnection readList readNew writeList writeNew partnerID ownID host return $ NetworkConnection read write partnerID ownID connectionstate +createNetworkConnectionS :: ([a], Int) -> ([a], Int) -> String -> String -> (String, String) -> IO (NetworkConnection a) +createNetworkConnectionS (readList, readNew) (writeList, writeNew) partnerID ownID (hostname, port) = createNetworkConnection readList readNew writeList writeNew (Just partnerID) (Just ownID) hostname port + newEmulatedConnection :: DirectionalConnection a -> DirectionalConnection a -> IO (NetworkConnection a) newEmulatedConnection r w = do diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index b3e7070..99dbb6f 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -55,7 +55,7 @@ instance Serializable (NCon.NetworkConnection Value) where (writeList, writeUnread) <- DC.serializeConnection $ NCon.ncWrite con - serializeLabeledEntryMulti "NNetworkConnection" (NCon.ncRead con) $ sNext (NCon.ncWrite con) $ sNext (Data.Maybe.fromMaybe "" $ NCon.ncPartnerUserID con) $ sNext (Data.Maybe.fromMaybe "" $ NCon.ncOwnUserID con) $ sLast constate + serializeLabeledEntryMulti "SNetworkConnection" (NCon.ncRead con) $ sNext (NCon.ncWrite con) $ sNext (Data.Maybe.fromMaybe "" $ NCon.ncPartnerUserID con) $ sNext (Data.Maybe.fromMaybe "" $ NCon.ncOwnUserID con) $ sLast constate -- instance (Serializable a => Serializable (NCon.DirectionalConnection a)) where @@ -63,14 +63,15 @@ instance Serializable (NCon.DirectionalConnection Value) where serialize dcon = do (msg, msgUnread) <- DC.serializeConnection dcon - serializeLabeledEntryMulti "NDirectionalConnection" msg $ sLast msgUnread + serializeLabeledEntryMulti "SDirectionalConnection" msg $ sLast msgUnread instance Serializable NCon.ConnectionState where serialize = \case - NCon.Connected hostname port -> serializeLabeledEntryMulti "NConnected" hostname $ sLast port - NCon.Disconnected -> return "NDisconnected" - NCon.Emulated -> return "NEmulated" + NCon.Connected hostname port -> serializeLabeledEntryMulti "SConnected" hostname $ sLast port + -- NCon.Disconnected -> return "SDisconnected" + -- NCon.Emulated -> return "SEmulated" + _ -> throw $ UnserializableException "VChan can only be serialized when in Connected mode" instance Serializable Value where @@ -91,6 +92,7 @@ instance Serializable Value where VServerSocket {} -> throw $ UnserializableException "VServerSocket" VChan nc -> serializeLabeledEntry "VChan" nc + VChanSerial {} -> throw $ UnserializableException "VChanSerial (This is only used for sending VChans, and should never appear here)" -- VChan {} -> throw $ UnserializableException "VChan" {-VChan cc -> do putStrLn "Trying to serialize VChan" diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 1fffaba..0a63dc0 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -27,6 +27,7 @@ import Networking.NetworkConnection (newNetworkConnection, NetworkConnection (nc import Networking.Messages (Messages(Introduce)) +{- createServer :: Int -> IO (MVar.MVar (Map.Map String ConnectionInfo), Chan.Chan String, String) createServer port = do serverid <- UserID.newRandomUserID @@ -45,7 +46,7 @@ createServer port = do chan <- Chan.newChan forkIO $ acceptClients mvar chan sock serverid return (mvar, chan, serverid) - +-} createServerNew :: Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), Chan.Chan String) createServerNew port = do @@ -88,9 +89,9 @@ acceptClientNew mvar chan clientsocket = do networkconnectionmap <- MVar.takeMVar mvar case Map.lookup userid networkconnectionmap of Just networkconnection -> do -- This means we habe already spoken to this client - -- valCleaned <- NC.replaceVChanSerial val -- Replaces VChanSerial with VChans and their appropriate connection - -- ND.writeMessage (ncRead networkconnection) valCleaned - ND.writeMessage (ncRead networkconnection) val + valCleaned <- NC.replaceVChanSerial val -- Replaces VChanSerial with VChans and their appropriate connection + ND.writeMessage (ncRead networkconnection) valCleaned + -- ND.writeMessage (ncRead networkconnection) val MVar.putMVar mvar networkconnectionmap Nothing -> do putStrLn "Error during recieving a networkmessage: Introduction is needed prior to sending values!" @@ -137,7 +138,7 @@ hostaddressTypeToString hostaddress = do let (a, b, c, d) = hostAddressToTuple hostaddress show a ++ "." ++ show b ++ "."++ show c ++ "." ++ show d - +{- acceptClients :: MVar.MVar (Map.Map String ConnectionInfo) -> Chan.Chan String -> Socket -> String-> IO () acceptClients mvar chan socket serverid = do putStrLn "Waiting for clients" @@ -157,6 +158,7 @@ acceptClient mvar chan clientsocket serverid = do MVar.modifyMVar_ mvar (return . Map.insert userid (ConnectionInfo hdl (snd clientsocket) r w)) forkIO $ NC.recieveMessagesID r mvar userid Chan.writeChan chan userid +-} waitForIntroduction :: Handle -> String -> IO String waitForIntroduction handle serverid = do diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index 9470327..07503c3 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -56,6 +56,7 @@ data Value -- | VChan (C.Chan Value) (C.Chan Value) (Maybe Handle) (Maybe SockAddr) (Maybe String) (Maybe String) -- | VChan CommunicationChannel | VChan (NCon.NetworkConnection Value) + | VChanSerial ([Value], Int) ([Value], Int) String String (String, String) -- | VChanSerial [Value] Int [Value] Int String String String String -- Maybe replace this with an VChan Either comchan or this -- Read Chan Write Chan Handle of Con Address of other other Userid own UserID @@ -74,7 +75,7 @@ data Value -- Own Port Number deriving Eq - +{- data ConnectionInfo = ConnectionInfo {ciHandle :: Handle, ciAddr :: SockAddr, ciReadChannel :: DirectionalConnection Value, ciWriteChannel :: DirectionalConnection Value} deriving Eq @@ -88,7 +89,7 @@ data ChannelState = Connected {csConInfoMap :: MVar.MVar (Map.Map String Connect | Emulated | Disabled -- Used when a Channel was sent --> Maybe we can automatically change this on serialization when we put this in a MVar deriving Eq - +-} -- If a channel is about to be send it should be deactivated disableVChan :: Value -> IO () diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 6c7d882..e3cd55b 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -108,6 +108,10 @@ import Networking.Messages sstringarray { T _ T.SStringArray } svaluesarray { T _ T.SValuesArray } + snetworkconnection {T _ T.SNetworkConnection} + sdirectionalconnection {T _ T.SDirectionalConnection} + sconnected {T _ T.SConnected} + nintroduce { T _ T.NIntroduce } nintroduceclient { T _ T.NIntroduceClient } nintroduceserver { T _ T.NIntroduceServer } @@ -174,6 +178,7 @@ Values : vunit { VUnit } | vdouble '(' double ')' {VDouble $3} | vstring '(' String ')' {VString $3 } -- | vchan '(' SValuesArray ')' '(' int ')' '(' SValuesArray ')' '(' int ')' '(' String ')' '(' String ')' '(' String ')' '(' String ')' {VChanSerial $3 $6 $9 $12 $15 $18 $21 $24 } + | vchan '(' NetworkConnection ')' {$3} | vsend '(' Values ')' {VSend $3} | vpair '(' Values ')' '(' Values ')' {VPair $3 $6} | vtype '(' Type ')' {VType $3} @@ -185,6 +190,12 @@ Values : vunit { VUnit } String : string {trimQuote $1} +NetworkConnection : snetworkconnection '(' DirectionalConnection ')' '(' DirectionalConnection ')' '(' String ')' '(' String ')' '(' ConnectionState ')' {VChanSerial $3 $6 $9 $12 $15} + +DirectionalConnection : sdirectionalconnection '(' SValuesArray ')' '(' int ')' {($3, $6)} + +ConnectionState : sconnected '(' String ')' '(' String ')' {($3, $6)} + Mult : mone { MOne } | mmany { MMany } diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index 8dce9e1..6869aab 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -122,6 +122,9 @@ tokens :- "SStringTypeArray" { tok $ const SStringTypeArray } "SStringArray" { tok $ const SStringArray } "SValuesArray" { tok $ const SValuesArray } + "SNetworkConnection" { tok $ const SNetworkConnection} + "SDirectionalConnection" { tok $ const SDirectionalConnection} + "SConnected" { tok $ const SConnected} "NIntroduce" { tok $ const NIntroduce } "NIntroduceClient" { tok $ const NIntroduceClient } @@ -238,6 +241,10 @@ data Token | SStringArray | SValuesArray + | SNetworkConnection + | SDirectionalConnection + | SConnected + | NIntroduce | NIntroduceClient | NIntroduceServer From 102eb395b23aabbbc2d79efbe5e71dec0b2cdaf9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 8 Dec 2022 11:16:19 +0100 Subject: [PATCH 049/229] Sending vchans now works initially --- src/Networking/Client.hs | 74 +++++++++++++++++++++++++++++++++++++++- src/Networking/Common.hs | 3 ++ 2 files changed, 76 insertions(+), 1 deletion(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index c9de0ae..523348e 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -15,6 +15,10 @@ import qualified Networking.UserID as UserID import qualified Data.Map as Map import GHC.IO.Handle import qualified Data.Maybe +import Networking.NetworkConnection (NetworkConnection(ncConnectionState), ConnectionState (Disconnected)) +import qualified Networking.Messages as Messages +import qualified Control.Concurrent as MVar +import qualified Control.Concurrent as MVar sendMessage :: NetworkConnection Value -> Value -> IO () sendMessage networkconnection val = do @@ -34,7 +38,8 @@ sendMessage networkconnection val = do putStrLn "After connect" handle <- NC.getHandle clientsocket putStrLn "Client connected: Sending Message" - NC.sendMessage (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) val) handle + valcleaned <- makeVChanSendable hostname port val + NC.sendMessage (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) valcleaned) handle DC.writeMessage (ncWrite networkconnection) val hClose handle NCon.Disconnected -> putStrLn "Error when sending message: This channel is disconnected" @@ -42,6 +47,31 @@ sendMessage networkconnection val = do MVar.putMVar (ncConnectionState networkconnection) connectionstate +sendNetworkMessage :: NetworkConnection Value -> Messages -> IO () +sendNetworkMessage networkconnection message = do + let hints = defaultHints { + addrFlags = [] + , addrSocketType = Stream + } + connectionstate <- MVar.takeMVar $ ncConnectionState networkconnection + case connectionstate of + NCon.Connected hostname port -> do + putStrLn $ "Trying to connect to: " ++ hostname ++":"++port + addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port + --addrInfo <- getAddrInfo (Just hints) (Just "127.0.0.1") $ Just port -- Thia is obviously only for testing + clientsocket <- NC.openSocketNC $ head addrInfo + putStrLn "Before connect" + connect clientsocket $ addrAddress $ head addrInfo + putStrLn "After connect" + handle <- NC.getHandle clientsocket + putStrLn "Client connected: Sending NetworkMessage" + NC.sendMessage message handle + hClose handle + NCon.Disconnected -> putStrLn "Error when sending message: This channel is disconnected" + NCon.Emulated -> pure () + MVar.putMVar (ncConnectionState networkconnection) connectionstate + + initialConnect :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> IO Value initialConnect mvar hostname port ownport= do let hints = defaultHints { @@ -67,3 +97,45 @@ initialConnect mvar hostname port ownport= do -- openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) +makeVChanSendable :: String -> String -> Value -> IO Value +makeVChanSendable newhost newport input = case input of + VSend v -> do + nv <- makeVChanSendable newhost newport v + return $ VSend nv + VPair v1 v2 -> do + nv1 <- makeVChanSendable newhost newport v1 + nv2 <- makeVChanSendable newhost newport v2 + return $ VPair nv1 nv2 + VFunc penv a b -> do + newpenv <- makeVChanSendablePEnv newhost newport penv + return $ VFunc newpenv a b + VDynCast v g -> do + nv <- makeVChanSendable newhost newport v + return $ VDynCast nv g + VFuncCast v a b -> do + nv <- makeVChanSendable newhost newport v + return $ VFuncCast nv a b + VRec penv a b c d -> do + newpenv <- makeVChanSendablePEnv newhost newport penv + return $ VRec newpenv a b c d + VNewNatRec penv a b c d e f g -> do + newpenv <- makeVChanSendablePEnv newhost newport penv + return $ VNewNatRec newpenv a b c d e f g + VChan nc -> do + putStrLn "Attempting to sending VChan" + -- connectionstate <- MVar.readMVar $ ncConnectionState nc + -- putStrLn "Aquired connectionstate" + sendNetworkMessage nc (Messages.ChangePartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID nc) newhost newport) + -- MVar.putMVar (ncConnectionState nc) Disconnected + -- _ <- MVar.takeMVar $ ncConnectionState nc + -- MVar.putMVar (ncConnectionState nc) Disconnected + putStrLn "Sent VChan" + return $ VChan nc + _ -> return input + where + makeVChanSendablePEnv :: String -> String -> [(String, Value)] -> IO [(String, Value)] + makeVChanSendablePEnv _ _ [] = return [] + makeVChanSendablePEnv newhost newport (x:xs) = do + newval <- makeVChanSendable newhost newport $ snd x + rest <- makeVChanSendablePEnv newhost newport xs + return $ (fst x, newval):rest \ No newline at end of file diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index e877ba2..7e7e296 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -168,6 +168,9 @@ replaceVChanSerial input = case input of + + + {- replaceVChanSerial :: Value -> IO Value replaceVChanSerial input = case input of From 1c7fa3e705f04db42dd22a04e200f42a98a71a59 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 8 Dec 2022 11:46:49 +0100 Subject: [PATCH 050/229] Removed unused code --- src/Interpreter.hs | 66 -------------------- src/Networking/Common.hs | 126 -------------------------------------- src/Networking/Server.hs | 44 ------------- src/ProcessEnvironment.hs | 80 +----------------------- 4 files changed, 1 insertion(+), 315 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index caa519c..4ef1035 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -165,26 +165,15 @@ eval = \case C.traceIO "Ran a forked operation") return VUnit New t -> do - -- r <- liftIO Chan.newChan - -- w <- liftIO Chan.newChan - -- return $ VPair (VChan r w Nothing Nothing Nothing Nothing) (VChan w r Nothing Nothing Nothing Nothing) r <- liftIO DC.newConnection w <- liftIO DC.newConnection - {-channelstate1 <- liftIO MVar.newEmptyMVar - liftIO $ MVar.putMVar channelstate1 Emulated - channelstate2 <- liftIO MVar.newEmptyMVar - liftIO $ MVar.putMVar channelstate2 Emulated - return $ VPair (VChan (CommunicationChannel r w Nothing Nothing channelstate1)) (VChan (CommunicationChannel w r Nothing Nothing channelstate2))-} nc1 <- liftIO $ NCon.newEmulatedConnection r w nc2 <- liftIO $ NCon.newEmulatedConnection w r return $ VPair (VChan nc1) $ VChan nc2 Send e -> VSend <$> interpret' e -- Apply VSend to the output of interpret' e Recv e -> do interpret' e >>= \v@(VChan ci) -> do - -- let dcRead = ccRead ci let dcRead = NCon.ncRead ci - - -- val <- liftIO $ Chan.readChan c val <- liftIO $ DC.readUnreadMessage dcRead liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e return $ VPair val v @@ -195,10 +184,8 @@ eval = \case val <- interpret' e case val of VInt port -> do - -- mvar <- liftIO MVar.newEmptyMVar (mvar, chan) <- liftIO $ NS.createServerNew port liftIO $ C.traceIO "Socket created" - -- return $ VServerSocket mvar return $ VServerSocket mvar chan $ show port _ -> throw $ NotAnExpectedValueException "VInt" val @@ -208,14 +195,8 @@ eval = \case val <- interpret' e case val of VServerSocket mvar chan ownport -> do - -- socket <- liftIO $ MVar.readMVar socketMVar newuser <- liftIO $ Chan.readChan chan - -- clientuser <- liftIO $ NC.getConnectionInfo mvar newuser liftIO $ C.traceIO "Client accepted" - -- return $ VChan (ciReadChannel clientuser) (ciWriteChannel clientuser) (Just $ ciHandle clientuser ) (Just $ ciAddr clientuser ) (Just newuser) $ Just serverid - -- channelstate <- liftIO MVar.newEmptyMVar - -- liftIO $ MVar.putMVar channelstate $ Connected mvar - -- return $ VChan $ CommunicationChannel (ciReadChannel clientuser) (ciWriteChannel clientuser) (Just newuser) (Just serverid) channelstate networkconnectionmap <- liftIO $ MVar.readMVar mvar case Map.lookup newuser networkconnectionmap of Nothing -> throw $ CommunicationPartnerNotFoundException newuser @@ -237,40 +218,6 @@ eval = \case case portVal of VInt port -> do liftIO $ NClient.initialConnect networkconmapmvar address (show port) ownport - {- - -- socketmvar <- liftIO newEmptyMVar - -- liftIO $ forkIO $ runTCPClient address (show port) $ putMVar socketmvar - -- socket <- liftIO $ readMVar socketmvar - -- liftIO $ forkIO $ NC.communicate r w socket - -- liftIO $ forkIO $ runTCPClient address (show port) (NC.communicate r w) - let hints = defaultHints { - addrFlags = [] - , addrSocketType = Stream - } - addrInfo <- liftIO $ getAddrInfo (Just hints) (Just address) $ Just $ show port - clientsocket <- liftIO $ openSocket $ head addrInfo - liftIO $ connect clientsocket $ addrAddress $ head addrInfo - -- liftIO $ forkIO $ NC.communicate r w clientsocket - handle <- liftIO $ NC.getHandle clientsocket - liftIO $ C.traceIO "Client connected" - ownuserid <- liftIO UserID.newRandomUserID - liftIO $ NC.sendMessage (Messages.Introduce ownuserid) handle - - -- Wait for answer from the server - serverid <- liftIO $ NC.waitForServerIntroduction handle - - -- Hockup automatic message recieving - mvar <- liftIO MVar.newEmptyMVar - liftIO $ MVar.putMVar mvar (Map.fromList [(serverid, ConnectionInfo handle (addrAddress $ head addrInfo) r w )]) - liftIO $ forkIO $ NC.recieveMessagesID r mvar serverid - - - -- return $ VChan r w (Just handle) (Just $ addrAddress $ head addrInfo) (Just serverid) $ Just ownuserid - channelstate <- liftIO MVar.newEmptyMVar - liftIO $ MVar.putMVar channelstate $ Connected mvar - - return $ VChan $ CommunicationChannel r w (Just serverid) (Just ownuserid) channelstate - -} _ -> throw $ NotAnExpectedValueException "VInt" portVal _ -> throw $ NotAnExpectedValueException "VString" addressVal _ -> throw $ NotAnExpectedValueException "VServerSocket" serversocket @@ -313,19 +260,6 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) interpretApp _ (VSend v@(VChan cc)) w = do liftIO $ putStrLn $ "Trying to send message:" ++ show w liftIO $ NClient.sendMessage cc w - -- liftIO (Chan.writeChan c w) - {- - liftIO $ DC.writeMessage (ccWrite cc) w - channelstate <- liftIO $ MVar.readMVar (ccChannelState cc) - case ccPartnerUserID cc of - Just partnerid -> case ccOwnUserID cc of - Just ownuserid -> liftIO $ NC.sendMessageID w (csConInfoMap channelstate) partnerid ownuserid - Nothing -> pure () - Nothing -> pure () - --case handle of - -- Nothing -> pure () - -- Just hdl -> liftIO $ NC.sendMessage w hdl - -} return v interpretApp e _ _ = throw $ ApplicationException e diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 7e7e296..f3409d0 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -36,53 +36,6 @@ instance Show ServerException where instance Exception ServerException - -{- - --- Hangs if no valid client id is provided -getConnectionInfo :: MVar.MVar (Map String ConnectionInfo) -> String -> IO ConnectionInfo -getConnectionInfo mvar user = do - dict <- MVar.readMVar mvar - case Map.lookup user dict of - Nothing -> getConnectionInfo mvar user - Just clientinfo -> return clientinfo - --- This waits until the handle is found -userIDToHandle :: MVar.MVar (Map.Map String ConnectionInfo) -> String -> IO Handle -userIDToHandle mvar userid = do - useridmap <- readMVar mvar - case Map.lookup userid useridmap of - Just connectioninfo -> return $ ciHandle connectioninfo - Nothing -> userIDToHandle mvar userid - -sendMessageID :: Value -> MVar.MVar (Map.Map String ConnectionInfo) -> String -> String -> IO () -sendMessageID value handlemapmvar partnerid userid = do - serializedValue <- NSerialize.serialize $ NewValue userid value - putStrLn $ "Sending message:" ++ serializedValue - handle <- userIDToHandle handlemapmvar partnerid - hPutStrLn handle (serializedValue ++ " ") - - -recieveMessagesID :: DirectionalConnection Value -> MVar.MVar (Map.Map String ConnectionInfo) -> String -> IO () -recieveMessagesID chan mvar userid = do - handle <- userIDToHandle mvar userid - message <- hGetLine handle - putStrLn $ "Recieved message:" ++ message - case VT.runAlex message VG.parseMessages of - -- case VT.runAlex message VG.parseValues of - Left err -> putStrLn $ "Error during recieving a networkmessage: "++err - Right deserialmessages -> case deserialmessages of - NewValue userid val -> do - -- valCleaned <- replaceVChanSerial val -- Replaces VChanSerial with VChans and their appropriate connection - -- DC.writeMessage chan valCleaned - DC.writeMessage chan val - _ -> do - serial <- NSerialize.serialize deserialmessages - putStrLn $ "Error unsupported networkmessage: "++ serial - recieveMessagesID chan mvar userid - --} - sendMessage :: NSerialize.Serializable a => a -> Handle -> IO () sendMessage value handle = do serializedValue <- NSerialize.serialize value @@ -166,84 +119,5 @@ replaceVChanSerial input = case input of rest <- replaceVChanSerialPEnv xs return $ (fst x, newval):rest - - - - - -{- -replaceVChanSerial :: Value -> IO Value -replaceVChanSerial input = case input of - VSend v -> do - nv <- replaceVChanSerial v - return $ VSend nv - VPair v1 v2 -> do - nv1 <- replaceVChanSerial v1 - nv2 <- replaceVChanSerial v2 - return $ VPair nv1 nv2 - VFunc penv a b -> do - newpenv <- replaceVChanSerialPEnv penv - return $ VFunc newpenv a b - VDynCast v g -> do - nv <- replaceVChanSerial v - return $ VDynCast nv g - VFuncCast v a b -> do - nv <- replaceVChanSerial v - return $ VFuncCast nv a b - VRec penv a b c d -> do - newpenv <- replaceVChanSerialPEnv penv - return $ VRec newpenv a b c d - VNewNatRec penv a b c d e f g -> do - newpenv <- replaceVChanSerialPEnv penv - return $ VNewNatRec newpenv a b c d e f g - VChanSerial r ri w wi pid oid p h -> do - putStrLn "Attempting to deserialize a VChanSerial" - getVChanFromSerial r ri w wi pid oid p h - _ -> return input - where - replaceVChanSerialPEnv :: [(String, Value)] -> IO [(String, Value)] - replaceVChanSerialPEnv [] = return [] - replaceVChanSerialPEnv (x:xs) = do - newval <- replaceVChanSerial $ snd x - rest <- replaceVChanSerialPEnv xs - return $ (fst x, newval):rest - -getVChanFromSerial :: [Value] -> Int -> [Value] -> Int -> String -> String -> String -> String -> IO Value -getVChanFromSerial msgRead readCount msgWrite writeCount partnerID ownID port hostname = do - readDC <- DC.createConnection msgRead readCount - writeDC <- DC.createConnection msgWrite writeCount - channelstate <- MVar.newEmptyMVar - - -- Connect to partner - let hints = defaultHints { - addrFlags = [] - , addrSocketType = Stream - } - - putStrLn $ "getVChanFromSerial: Trying to connect to new partner: " ++ hostname ++ ":" ++ port - addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port - clientsocket <- openSocketNC $ head addrInfo - putStrLn "getVChanFromSerial: Aquired socket" - connect clientsocket $ addrAddress $ head addrInfo - putStrLn "getVChanFromSerial: Connected to socket" - handle <- getHandle clientsocket - putStrLn "getVChanFromSerial: Converted to handle" - sendMessage (Introduce ownID) handle - putStrLn "getVChanFromSerial: Waiting for handshake" - serverid <- waitForServerIntroduction handle - putStrLn "getVChanFromSerial: Handshake recieved" - if partnerID == serverid then do - putStrLn "getVChanFromSerial: Handshake valid" - -- Hookup automatic message recieving - mvar <- liftIO MVar.newEmptyMVar - MVar.putMVar mvar (Map.fromList [(serverid, ConnectionInfo handle (addrAddress $ head addrInfo) readDC writeDC )]) - forkIO $ recieveMessagesID readDC mvar serverid - MVar.putMVar channelstate $ Connected mvar - putStrLn "getVChanFromSerial: Message revieving hooked up" - else MVar.putMVar channelstate Disconnected - return $ VChan $ CommunicationChannel readDC writeDC (Just partnerID) (Just ownID) channelstate - --} - -- openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) openSocketNC addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) \ No newline at end of file diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 0a63dc0..1520373 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -26,28 +26,6 @@ import qualified Control.Concurrent as MVar import Networking.NetworkConnection (newNetworkConnection, NetworkConnection (ncConnectionState)) import Networking.Messages (Messages(Introduce)) - -{- -createServer :: Int -> IO (MVar.MVar (Map.Map String ConnectionInfo), Chan.Chan String, String) -createServer port = do - serverid <- UserID.newRandomUserID - sock <- liftIO $ socket AF_INET Stream 0 - liftIO $ setSocketOption sock ReuseAddr 1 - let hints = defaultHints { - addrFlags = [AI_PASSIVE] - , addrSocketType = Stream - } - addrInfo <- liftIO $ getAddrInfo (Just hints) Nothing $ Just $ show port - - liftIO $ bind sock $ addrAddress $ head addrInfo - liftIO $ listen sock 2 - mvar <- MVar.newEmptyMVar - MVar.putMVar mvar Map.empty - chan <- Chan.newChan - forkIO $ acceptClients mvar chan sock serverid - return (mvar, chan, serverid) --} - createServerNew :: Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), Chan.Chan String) createServerNew port = do serverid <- UserID.newRandomUserID @@ -138,28 +116,6 @@ hostaddressTypeToString hostaddress = do let (a, b, c, d) = hostAddressToTuple hostaddress show a ++ "." ++ show b ++ "."++ show c ++ "." ++ show d -{- -acceptClients :: MVar.MVar (Map.Map String ConnectionInfo) -> Chan.Chan String -> Socket -> String-> IO () -acceptClients mvar chan socket serverid = do - putStrLn "Waiting for clients" - clientsocket <- accept socket - putStrLn "Accepted new client" - - forkIO $ acceptClient mvar chan clientsocket serverid - acceptClients mvar chan socket serverid - - -acceptClient :: MVar.MVar (Map.Map String ConnectionInfo) -> Chan.Chan String -> (Socket, SockAddr) -> String -> IO () -acceptClient mvar chan clientsocket serverid = do - hdl <- NC.getHandle $ fst clientsocket - userid <- waitForIntroduction hdl serverid - r <- ND.newConnection - w <- ND.newConnection - MVar.modifyMVar_ mvar (return . Map.insert userid (ConnectionInfo hdl (snd clientsocket) r w)) - forkIO $ NC.recieveMessagesID r mvar userid - Chan.writeChan chan userid --} - waitForIntroduction :: Handle -> String -> IO String waitForIntroduction handle serverid = do message <- hGetLine handle diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index 07503c3..0a1822d 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -51,16 +51,8 @@ data Value | VInt Int | VDouble Double | VString String - -- we have two channels, one for reading and one for writing to the other - -- end, so we do not read our own written values - -- | VChan (C.Chan Value) (C.Chan Value) (Maybe Handle) (Maybe SockAddr) (Maybe String) (Maybe String) - -- | VChan CommunicationChannel | VChan (NCon.NetworkConnection Value) | VChanSerial ([Value], Int) ([Value], Int) String String (String, String) - -- | VChanSerial [Value] Int [Value] Int String String String String - -- Maybe replace this with an VChan Either comchan or this - -- Read Chan Write Chan Handle of Con Address of other other Userid own UserID --- | VChan (C.Chan Value) (C.Chan Value) | VSend Value | VPair Value Value -- pair of ids that map to two values | VType S.Type @@ -69,80 +61,10 @@ data Value | VFuncCast Value FuncType FuncType -- (Value : (ρ,α,Π(x:A)A') => (ρ,α,Π(x:B)B')) | VRec PEnv String String Exp Exp | VNewNatRec PEnv String String String Type Exp String Exp - -- | VServerSocket (MVar.MVar Socket) - -- | VServerSocket Socket | VServerSocket (MVar.MVar (Map.Map String (NCon.NetworkConnection Value))) (C.Chan String) String -- Own Port Number deriving Eq -{- -data ConnectionInfo = ConnectionInfo {ciHandle :: Handle, ciAddr :: SockAddr, ciReadChannel :: DirectionalConnection Value, ciWriteChannel :: DirectionalConnection Value} - deriving Eq - --- data CommunicationChannel = CommunicationChannel {ccRead :: DirectionalConnection Value, ccWrite :: DirectionalConnection Value, ccPartnerUserID :: Maybe String, ccOwnUserID :: Maybe String, ccPartnerAddress :: Maybe (MVar.MVar SockAddr), ccChannelState :: MVar.MVar ChannelState} -data CommunicationChannel = CommunicationChannel {ccRead :: DirectionalConnection Value, ccWrite :: DirectionalConnection Value, ccPartnerUserID :: Maybe String, ccOwnUserID :: Maybe String, ccChannelState :: MVar.MVar ChannelState} - deriving Eq - -- Change this to Maybe MVar SockAddr - -data ChannelState = Connected {csConInfoMap :: MVar.MVar (Map.Map String ConnectionInfo)} - | Disconnected - | Emulated - | Disabled -- Used when a Channel was sent --> Maybe we can automatically change this on serialization when we put this in a MVar - deriving Eq --} - --- If a channel is about to be send it should be deactivated -disableVChan :: Value -> IO () -disableVChan = \case - VSend v -> disableVChan v - VPair v1 v2 -> disableVChan v1 >> disableVChan v2 - VFunc penv _ _ -> disableVChanArr penv - VDynCast v _ -> disableVChan v - VFuncCast v _ _ -> disableVChan v - VRec penv _ _ _ _ -> disableVChanArr penv - VNewNatRec penv _ _ _ _ _ _ _ -> disableVChanArr penv - VChan cc -> do - channelstate <- MVar.takeMVar $ NCon.ncConnectionState cc - case channelstate of - NCon.Connected {} -> MVar.putMVar (NCon.ncConnectionState cc) NCon.Disconnected - _ -> MVar.putMVar (NCon.ncConnectionState cc) channelstate - _ -> return () - where - disableVChanArr :: PEnv -> IO () - disableVChanArr [] = return () - disableVChanArr (x:xs) = disableVChan (snd x) >> disableVChanArr xs - - -{- - -disableVChan :: Value -> IO () -disableVChan = \case - VSend v -> disableVChan v - VPair v1 v2 -> disableVChan v1 >> disableVChan v2 - VFunc penv _ _ -> disableVChanArr penv - VDynCast v _ -> disableVChan v - VFuncCast v _ _ -> disableVChan v - VRec penv _ _ _ _ -> disableVChanArr penv - VNewNatRec penv _ _ _ _ _ _ _ -> disableVChanArr penv - VChan cc -> do - channelstate <- MVar.takeMVar $ ccChannelState cc - case channelstate of - Connected infomap -> MVar.putMVar (ccChannelState cc) Disabled - _ -> MVar.putMVar (ccChannelState cc) channelstate - _ -> return () - where - disableVChanArr :: PEnv -> IO () - disableVChanArr [] = return () - disableVChanArr (x:xs) = disableVChan (snd x) >> disableVChanArr xs - - - - --} - - - - instance Show Value where show = \case @@ -152,7 +74,7 @@ instance Show Value where VDouble d -> "VDouble " ++ show d VString s -> "VString \"" ++ show s ++ "\"" VChan {} -> "VChan" - -- VChanSerial {} -> "VChanSerial" + VChanSerial {} -> "VChanSerial" VSend v -> "VSend (" ++ show v ++ ")" VPair a b -> "VPair <" ++ show a ++ ", " ++ show b ++ ">" VType t -> "VType " ++ show t From b1faf5cd85ad96808f36b646906ffe1771f5edad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 8 Dec 2022 13:00:33 +0100 Subject: [PATCH 051/229] Old VChans get now disabled --- src/Interpreter.hs | 14 ++++++-- src/Networking/Client.hs | 5 ++- src/Networking/Server.hs | 6 ++-- src/ProcessEnvironment.hs | 74 +++++++++++++++++++++++++++++++++++++++ 4 files changed, 92 insertions(+), 7 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 4ef1035..b331a73 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -46,6 +46,7 @@ import qualified Networking.NetworkConnection as NCon -- import ProcessEnvironment (CommunicationChannel(CommunicationChannel, ccChannelState, ccPartnerUserID), ConnectionInfo (ciReadChannel, ciWriteChannel)) -- import ProcessEnvironment import qualified Control.Concurrent as MVar +import ProcessEnvironment (disableOldVChan) -- import qualified Networking.NetworkConnection as NCon -- import qualified Networking.NetworkConnection as NCon @@ -174,9 +175,13 @@ eval = \case Recv e -> do interpret' e >>= \v@(VChan ci) -> do let dcRead = NCon.ncRead ci - val <- liftIO $ DC.readUnreadMessage dcRead + valunclean <- liftIO $ DC.readUnreadMessage dcRead + val <- liftIO $ NC.replaceVChanSerial valunclean liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e - return $ VPair val v + + -- Disable the old channel and get a new one + newV <- liftIO $ disableOldVChan v + return $ VPair val newV Case e cases -> interpret' e >>= \(VLabel s) -> interpret' $ fromJust $ lookup s cases Create e -> do liftIO $ C.traceIO "Creating socket!" @@ -260,7 +265,10 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) interpretApp _ (VSend v@(VChan cc)) w = do liftIO $ putStrLn $ "Trying to send message:" ++ show w liftIO $ NClient.sendMessage cc w - return v + + -- Disable old VChan + newV <- liftIO $ disableOldVChan v + return newV interpretApp e _ _ = throw $ ApplicationException e interpretLit :: Literal -> Value diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 523348e..cf1271f 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -40,7 +40,10 @@ sendMessage networkconnection val = do putStrLn "Client connected: Sending Message" valcleaned <- makeVChanSendable hostname port val NC.sendMessage (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) valcleaned) handle - DC.writeMessage (ncWrite networkconnection) val + DC.writeMessage (ncWrite networkconnection) valcleaned + putStrLn "Disabling Chans" + disableVChans val -- Disables all sent VChans for the sending party + putStrLn "Chans disabled" hClose handle NCon.Disconnected -> putStrLn "Error when sending message: This channel is disconnected" NCon.Emulated -> DC.writeMessage (ncWrite networkconnection) val diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 1520373..017a980 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -67,9 +67,9 @@ acceptClientNew mvar chan clientsocket = do networkconnectionmap <- MVar.takeMVar mvar case Map.lookup userid networkconnectionmap of Just networkconnection -> do -- This means we habe already spoken to this client - valCleaned <- NC.replaceVChanSerial val -- Replaces VChanSerial with VChans and their appropriate connection - ND.writeMessage (ncRead networkconnection) valCleaned - -- ND.writeMessage (ncRead networkconnection) val + -- valCleaned <- NC.replaceVChanSerial val -- Replaces VChanSerial with VChans and their appropriate connection + -- ND.writeMessage (ncRead networkconnection) valCleaned + ND.writeMessage (ncRead networkconnection) val MVar.putMVar mvar networkconnectionmap Nothing -> do putStrLn "Error during recieving a networkmessage: Introduction is needed prior to sending values!" diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index 0a1822d..cd421df 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -17,6 +17,8 @@ import qualified Networking.NetworkConnection as NCon import Network.Socket import qualified Networking.NetworkConnection as NCon +import qualified Networking.NetworkConnection as NCOn +import qualified Networking.NetworkConnection as Ncon -- import qualified Networking.Common as NC -- | the interpretation monad @@ -65,6 +67,78 @@ data Value -- Own Port Number deriving Eq +disableOldVChan :: Value -> IO Value +disableOldVChan value = case value of + VChan nc -> do + constate <- MVar.newEmptyMVar + oldconstate <- MVar.takeMVar $ NCon.ncConnectionState nc + MVar.putMVar constate oldconstate + MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected + let newNC = NCon.NetworkConnection (NCon.ncRead nc) (NCon.ncWrite nc) (NCOn.ncPartnerUserID nc) (NCon.ncOwnUserID nc) constate + return $ VChan newNC + _ -> return value + + +disableVChan :: Value -> IO () +disableVChan value = case value of + VChan nc -> do + -- constate <- MVar.newEmptyMVar + -- MVar.putMVar constate NCon.Disconnected + -- let newNC = NCon.NetworkConnection (NCon.ncRead nc) (NCon.ncWrite nc) (NCOn.ncPartnerUserID nc) (NCon.ncOwnUserID nc) constate + putStrLn "Taking MVar" + _ <- MVar.tryTakeMVar $ NCon.ncConnectionState nc --I dont fully understand why this mvar isnt filled but lets bypass this problem + putStrLn "MVar cleared" + MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected + putStrLn "MVar written" + -- return $ VChan nc + -- return $ VChan newNC + _ -> return () --return value + + + +disableVChans :: Value -> IO () +disableVChans input = case input of + VSend v -> do + nv <- disableVChans v + return () + -- return $ VSend nv + VPair v1 v2 -> do + nv1 <- disableVChans v1 + nv2 <- disableVChans v2 + return () + -- return $ VPair nv1 nv2 + VFunc penv a b -> do + newpenv <- disableVChansPEnv penv + return () + -- return $ VFunc newpenv a b + VDynCast v g -> do + nv <- disableVChans v + return () + -- return $ VDynCast nv g + VFuncCast v a b -> do + nv <- disableVChans v + return () + -- return $ VFuncCast nv a b + VRec penv a b c d -> do + newpenv <- disableVChansPEnv penv + return () + -- return $ VRec newpenv a b c d + VNewNatRec penv a b c d e f g -> do + newpenv <- disableVChansPEnv penv + return () + -- return $ VNewNatRec newpenv a b c d e f g + _ -> disableVChan input -- This handles vchans and the default case + where + disableVChansPEnv :: [(String, Value)] -> IO () + disableVChansPEnv [] = return () + disableVChansPEnv (x:xs) = do + newval <- disableVChans $ snd x + rest <- disableVChansPEnv xs + return () + -- return $ (fst x, newval):rest + + + instance Show Value where show = \case From 72c2c9c90c8b0821e58144efe604a60954a64845 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 8 Dec 2022 14:38:04 +0100 Subject: [PATCH 052/229] Added support for resynchonization --- src/Networking/DirectionalConnection.hs | 8 +++++- src/Networking/Serialize.hs | 2 +- src/Networking/Server.hs | 33 ++++++++++++++++++++++--- src/ValueParsing/ValueGrammar.y | 6 +++++ src/ValueParsing/ValueTokens.x | 2 ++ 5 files changed, 46 insertions(+), 5 deletions(-) diff --git a/src/Networking/DirectionalConnection.hs b/src/Networking/DirectionalConnection.hs index ebb4f04..f9964b5 100644 --- a/src/Networking/DirectionalConnection.hs +++ b/src/Networking/DirectionalConnection.hs @@ -1,4 +1,4 @@ -module Networking.DirectionalConnection (DirectionalConnection(..), newConnection, createConnection, writeMessage, allMessages, readUnreadMessage, readUnreadMessageMaybe, serializeConnection) where +module Networking.DirectionalConnection (DirectionalConnection(..), newConnection, createConnection, writeMessage, allMessages, readUnreadMessage, readUnreadMessageMaybe, serializeConnection, syncMessages) where import Control.Concurrent.MVar @@ -31,6 +31,12 @@ writeMessage connection message = do return $ m ++ [message] ) +-- This relies on the message array giving having the same first entrys as the internal messages +syncMessages :: DirectionalConnection a -> [a] -> IO () +syncMessages connection msgs = do + mymessages <- takeMVar $ messages connection + if length mymessages < length msgs then putMVar (messages connection) msgs else putMVar (messages connection) mymessages + -- Gives all outMessages until this point allMessages :: DirectionalConnection a -> IO [a] allMessages connection = readMVar (messages connection) diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index 99dbb6f..a11845e 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -92,7 +92,7 @@ instance Serializable Value where VServerSocket {} -> throw $ UnserializableException "VServerSocket" VChan nc -> serializeLabeledEntry "VChan" nc - VChanSerial {} -> throw $ UnserializableException "VChanSerial (This is only used for sending VChans, and should never appear here)" + VChanSerial r w p o c -> serializeLabeledEntryMulti "VChanSerial" r $ sNext w $ sNext p $ sNext c $ sLast c -- VChan {} -> throw $ UnserializableException "VChan" {-VChan cc -> do putStrLn "Trying to serialize VChan" diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 017a980..909ddcb 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -6,6 +6,7 @@ import qualified Control.Concurrent.Chan as Chan import Control.Concurrent (forkIO) import Control.Monad.IO.Class import qualified Data.Map as Map +import qualified Data.Maybe import GHC.IO.Handle import Network.Socket @@ -20,11 +21,12 @@ import Control.Exception import qualified Networking.UserID as UserID import qualified Networking.Messages as Messages import qualified Networking.DirectionalConnection as ND +import qualified Networking.Client as NClient import Networking.NetworkConnection import qualified Control.Concurrent as MVar -import Networking.NetworkConnection (newNetworkConnection, NetworkConnection (ncConnectionState)) -import Networking.Messages (Messages(Introduce)) +import Networking.NetworkConnection (newNetworkConnection, NetworkConnection (ncConnectionState, ncOwnUserID)) +import Networking.Messages (Messages(Introduce, RequestSync, SyncIncoming)) createServerNew :: Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), Chan.Chan String) createServerNew port = do @@ -54,6 +56,8 @@ acceptClientsNew mvar chan socket = do forkIO $ acceptClientNew mvar chan clientsocket acceptClientsNew mvar chan socket + +-- In the nothing case we shoud wait a few seconds for other messages to resolve the issue acceptClientNew :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> Chan.Chan String -> (Socket, SockAddr) -> IO () acceptClientNew mvar chan clientsocket = do hdl <- NC.getHandle $ fst clientsocket @@ -103,8 +107,31 @@ acceptClientNew mvar chan clientsocket = do _ <- MVar.takeMVar constate MVar.putMVar constate $ Networking.NetworkConnection.Connected hostname port MVar.putMVar mvar networkconnectionmap - Nothing -> pure () -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that + -- Sync and request sync + NClient.sendNetworkMessage networkconnection (RequestSync $ Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) + writevals <- ND.allMessages $ ncWrite networkconnection + NClient.sendNetworkMessage networkconnection (SyncIncoming (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) writevals) + + Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that + RequestSync userid -> do + networkconnectionmap <- MVar.takeMVar mvar + case Map.lookup userid networkconnectionmap of + Just networkconnection -> do -- Change to current network address + MVar.putMVar mvar networkconnectionmap + -- Sync and request sync + writevals <- ND.allMessages $ ncWrite networkconnection + NClient.sendNetworkMessage networkconnection (SyncIncoming (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) writevals) + + Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that + SyncIncoming userid values -> do + networkconnectionmap <- MVar.takeMVar mvar + case Map.lookup userid networkconnectionmap of + Just networkconnection -> do -- Change to current network address + MVar.putMVar mvar networkconnectionmap + ND.syncMessages (ncRead networkconnection) values + + Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that _ -> do serial <- NSerialize.serialize deserialmessages putStrLn $ "Error unsupported networkmessage: "++ serial diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index e3cd55b..93d696e 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -34,6 +34,7 @@ import Networking.Messages vdouble { T _ T.VDouble } vstring { T _ T.VString } vchan { T _ T.VChan} + vchanserial { T _ T.VChanSerial} vsend { T _ T.VSend } vpair { T _ T.VPair } vtype { T _ T.VType } @@ -179,6 +180,7 @@ Values : vunit { VUnit } | vstring '(' String ')' {VString $3 } -- | vchan '(' SValuesArray ')' '(' int ')' '(' SValuesArray ')' '(' int ')' '(' String ')' '(' String ')' '(' String ')' '(' String ')' {VChanSerial $3 $6 $9 $12 $15 $18 $21 $24 } | vchan '(' NetworkConnection ')' {$3} + | vchanserial '(' SArrayIntElement ')' '(' SArrayIntElement ')' '(' String ')' '(' String ')' '(' SStringStringElement ')' {VChanSerial $3 $6 $9 $12 $15} | vsend '(' Values ')' {VSend $3} | vpair '(' Values ')' '(' Values ')' {VPair $3 $6} | vtype '(' Type ')' {VType $3} @@ -315,6 +317,10 @@ SValuesElements : Values ',' SValuesElements {$1 : $3} LabelType : slabeltype '{' SStringElements '}' {$3} +SArrayIntElement : '(' '(' SValuesArray ')' '(' int ')' ')' {($3, $6)} + +SStringStringElement : '(' '(' String ')' '(' String ')' ')' {($3, $6)} + { diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index 6869aab..8377f3a 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -36,6 +36,7 @@ tokens :- "VDouble" { tok $ const VDouble } "VString" { tok $ const VString } "VChan" { tok $ const VChan } + "VChanSerial" { tok $ const VChanSerial } "VSend" { tok $ const VSend } "VPair" { tok $ const VPair } "VType" { tok $ const VType } @@ -152,6 +153,7 @@ data Token | VDouble | VString | VChan + | VChanSerial | VSend | VPair | VType From 9e986debbca68039cba79153a1152b0a9369be37 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 8 Dec 2022 15:55:41 +0100 Subject: [PATCH 053/229] Added new test --- dev-examples/handoff2/client.ldgvnw | 20 ++++++++++++++++++++ dev-examples/handoff2/handoff.ldgvnw | 16 ++++++++++++++++ dev-examples/handoff2/server.ldgvnw | 25 +++++++++++++++++++++++++ 3 files changed, 61 insertions(+) create mode 100644 dev-examples/handoff2/client.ldgvnw create mode 100644 dev-examples/handoff2/handoff.ldgvnw create mode 100644 dev-examples/handoff2/server.ldgvnw diff --git a/dev-examples/handoff2/client.ldgvnw b/dev-examples/handoff2/client.ldgvnw new file mode 100644 index 0000000..704098a --- /dev/null +++ b/dev-examples/handoff2/client.ldgvnw @@ -0,0 +1,20 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let y = ((send x) 42) in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val main : Unit +val main = + let sock = (create 4444) in + let con = (connect sock SendInt "127.0.0.1" 4242 ) in -- This cannot be localhost, since this might break on containerized images + send2 con diff --git a/dev-examples/handoff2/handoff.ldgvnw b/dev-examples/handoff2/handoff.ldgvnw new file mode 100644 index 0000000..2d3a7e8 --- /dev/null +++ b/dev-examples/handoff2/handoff.ldgvnw @@ -0,0 +1,16 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit +type SendOneInt : ! ~ssn = ?Int. Unit +type SendSendOneInt : ! ~ssn = !SendOneInt. Unit +-- type SendOneIntInv : ! ~ssn = ?Int. Unit + +val main : Int +val main = + let sock = (create 4343) in + let con = (connect sock (dualof SendSendOneInt) "127.0.0.1" 4242) in + let = recv con in + let = recv oneint in + result + diff --git a/dev-examples/handoff2/server.ldgvnw b/dev-examples/handoff2/server.ldgvnw new file mode 100644 index 0000000..ce86c45 --- /dev/null +++ b/dev-examples/handoff2/server.ldgvnw @@ -0,0 +1,25 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit +type SendOneInt : ! ~ssn = ?Int. Unit +type SendSendOneInt : ! ~ssn = !SendOneInt. Unit +-- type SendOneIntInv : ! ~ssn = ?Int. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let y = ((send x) 42) in + () + +val add2 (c1: dualof SendInt) (c3: SendSendOneInt)= + let = recv c1 in + let y = ((send c3) c2) in + (m) + +-- Hier problematisch ldgv hat noch kein Konzept wie beim akzeptieren zwischen verschiedenen Types ungerschieden werden kann +val main : Int +val main = + let sock = (create 4242) in + let con1 = (accept sock (dualof SendInt)) in + let con2 = (accept sock (SendSendOneInt)) in + add2 con1 con2 From 7023ceb0f501c58992a2776075c32e5c0fce2434 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 8 Dec 2022 16:31:44 +0100 Subject: [PATCH 054/229] Update Client.hs --- src/Networking/Client.hs | 37 +++++++++++++++++++++++-------------- 1 file changed, 23 insertions(+), 14 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index cf1271f..335339d 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -19,6 +19,8 @@ import Networking.NetworkConnection (NetworkConnection(ncConnectionState), Conne import qualified Networking.Messages as Messages import qualified Control.Concurrent as MVar import qualified Control.Concurrent as MVar +import Control.Exception +import GHC.Exception sendMessage :: NetworkConnection Value -> Value -> IO () sendMessage networkconnection val = do @@ -29,6 +31,7 @@ sendMessage networkconnection val = do connectionstate <- MVar.takeMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port -> do + catch ( do putStrLn $ "Trying to connect to: " ++ hostname ++":"++port addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port --addrInfo <- getAddrInfo (Just hints) (Just "127.0.0.1") $ Just port -- Thia is obviously only for testing @@ -44,7 +47,7 @@ sendMessage networkconnection val = do putStrLn "Disabling Chans" disableVChans val -- Disables all sent VChans for the sending party putStrLn "Chans disabled" - hClose handle + hClose handle ) $ printConErr hostname port NCon.Disconnected -> putStrLn "Error when sending message: This channel is disconnected" NCon.Emulated -> DC.writeMessage (ncWrite networkconnection) val MVar.putMVar (ncConnectionState networkconnection) connectionstate @@ -59,22 +62,28 @@ sendNetworkMessage networkconnection message = do connectionstate <- MVar.takeMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port -> do - putStrLn $ "Trying to connect to: " ++ hostname ++":"++port - addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port - --addrInfo <- getAddrInfo (Just hints) (Just "127.0.0.1") $ Just port -- Thia is obviously only for testing - clientsocket <- NC.openSocketNC $ head addrInfo - putStrLn "Before connect" - connect clientsocket $ addrAddress $ head addrInfo - putStrLn "After connect" - handle <- NC.getHandle clientsocket - putStrLn "Client connected: Sending NetworkMessage" - NC.sendMessage message handle - hClose handle + catch ( do + putStrLn $ "Trying to connect to: " ++ hostname ++":"++port + addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port + --addrInfo <- getAddrInfo (Just hints) (Just "127.0.0.1") $ Just port -- Thia is obviously only for testing + clientsocket <- NC.openSocketNC $ head addrInfo + putStrLn "Before connect" + connect clientsocket $ addrAddress $ head addrInfo + putStrLn "After connect" + handle <- NC.getHandle clientsocket + putStrLn "Client connected: Sending NetworkMessage" + NC.sendMessage message handle + hClose handle ) $ printConErr hostname port NCon.Disconnected -> putStrLn "Error when sending message: This channel is disconnected" NCon.Emulated -> pure () MVar.putMVar (ncConnectionState networkconnection) connectionstate + +printConErr :: String -> String -> IOException -> IO () +printConErr hostname port err = putStrLn $ "Communication Partner " ++ hostname ++ ":" ++ port ++ "not found!" + + initialConnect :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> IO Value initialConnect mvar hostname port ownport= do let hints = defaultHints { @@ -125,14 +134,14 @@ makeVChanSendable newhost newport input = case input of newpenv <- makeVChanSendablePEnv newhost newport penv return $ VNewNatRec newpenv a b c d e f g VChan nc -> do - putStrLn "Attempting to sending VChan" + putStrLn "Attempting to sending ChangePartnerAddress" -- connectionstate <- MVar.readMVar $ ncConnectionState nc -- putStrLn "Aquired connectionstate" sendNetworkMessage nc (Messages.ChangePartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID nc) newhost newport) -- MVar.putMVar (ncConnectionState nc) Disconnected -- _ <- MVar.takeMVar $ ncConnectionState nc -- MVar.putMVar (ncConnectionState nc) Disconnected - putStrLn "Sent VChan" + putStrLn "Sent ChangePartnerAddress" return $ VChan nc _ -> return input where From 34025cbd67fe52c230c8e290d4ddb31e89ff792e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 14 Dec 2022 12:37:58 +0100 Subject: [PATCH 055/229] Client sends type now --- src/Interpreter.hs | 2 +- src/Networking/Client.hs | 7 ++++--- src/Networking/Messages.hs | 3 ++- src/Networking/Serialize.hs | 2 +- src/Networking/Server.hs | 2 +- src/ValueParsing/ValueGrammar.y | 2 +- 6 files changed, 10 insertions(+), 8 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index b331a73..f46022a 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -222,7 +222,7 @@ eval = \case portVal <- interpret' e2 case portVal of VInt port -> do - liftIO $ NClient.initialConnect networkconmapmvar address (show port) ownport + liftIO $ NClient.initialConnect networkconmapmvar address (show port) ownport t _ -> throw $ NotAnExpectedValueException "VInt" portVal _ -> throw $ NotAnExpectedValueException "VString" addressVal _ -> throw $ NotAnExpectedValueException "VServerSocket" serversocket diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 335339d..a7b856f 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -21,6 +21,7 @@ import qualified Control.Concurrent as MVar import qualified Control.Concurrent as MVar import Control.Exception import GHC.Exception +import qualified Syntax sendMessage :: NetworkConnection Value -> Value -> IO () sendMessage networkconnection val = do @@ -84,8 +85,8 @@ printConErr :: String -> String -> IOException -> IO () printConErr hostname port err = putStrLn $ "Communication Partner " ++ hostname ++ ":" ++ port ++ "not found!" -initialConnect :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> IO Value -initialConnect mvar hostname port ownport= do +initialConnect :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> Syntax.Type -> IO Value +initialConnect mvar hostname port ownport syntype= do let hints = defaultHints { addrFlags = [] , addrSocketType = Stream @@ -97,7 +98,7 @@ initialConnect mvar hostname port ownport= do handle <- NC.getHandle clientsocket ownuserid <- UserID.newRandomUserID putStrLn "Client connected: Introducing" - NC.sendMessage (Messages.IntroduceClient ownuserid ownport) handle + NC.sendMessage (Messages.IntroduceClient ownuserid ownport syntype) handle introductionanswer <- NC.waitForServerIntroduction handle putStrLn "Finished Handshake" hClose handle diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs index b086362..d0cd96f 100644 --- a/src/Networking/Messages.hs +++ b/src/Networking/Messages.hs @@ -1,6 +1,7 @@ module Networking.Messages where import ProcessEnvironment +import Syntax type Partner = String type Hostname = String @@ -8,7 +9,7 @@ type Port = String data Messages = Introduce Partner - | IntroduceClient Partner Port + | IntroduceClient Partner Port Type | IntroduceServer Partner | NewValue Partner Value | SyncIncoming Partner [Value] diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index a11845e..dba1127 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -40,7 +40,7 @@ class Serializable a where instance Serializable Messages where serialize = \case Introduce p -> serializeLabeledEntry "NIntroduce" p - IntroduceClient p port -> serializeLabeledEntryMulti "NIntroduceClient" p $ sLast port + IntroduceClient p port t -> serializeLabeledEntryMulti "NIntroduceClient" p $ sNext port $ sLast t IntroduceServer p -> serializeLabeledEntry "NIntroduceServer" p NewValue p v -> serializeLabeledEntryMulti "NNewValue" p $ sLast v SyncIncoming p vs -> serializeLabeledEntryMulti "NSyncIncoming" p $ sLast vs diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 909ddcb..31e84ce 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -78,7 +78,7 @@ acceptClientNew mvar chan clientsocket = do Nothing -> do putStrLn "Error during recieving a networkmessage: Introduction is needed prior to sending values!" MVar.putMVar mvar networkconnectionmap - IntroduceClient userid clientport -> do + IntroduceClient userid clientport syntype-> do networkconnectionmap <- MVar.takeMVar mvar case Map.lookup userid networkconnectionmap of Just networkconnection -> do diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 93d696e..efbea3e 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -271,7 +271,7 @@ GType : gunit {GUnit} | gstring {GString} Messages : nintroduce '(' String ')' {Introduce $3} - | nintroduceclient '(' String ')' '(' String ')' {IntroduceClient $3 $6} + | nintroduceclient '(' String ')' '(' String ')' '(' Type ')' {IntroduceClient $3 $6 $9} | nintroduceserver '(' String ')' {IntroduceServer $3} | nnewvalue '(' String ')''(' Values ')' {NewValue $3 $6} | nsyncincoming '(' String ')''(' SValuesArray ')' {SyncIncoming $3 $6} From efbc54696a9ce40caab811562411bab69ef4e5f9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 14 Dec 2022 14:29:15 +0100 Subject: [PATCH 056/229] Experimental Type detection --- src/Interpreter.hs | 9 ++--- src/Networking/Server.hs | 70 ++++++++++++++++++++++++++++----------- src/ProcessEnvironment.hs | 2 +- 3 files changed, 57 insertions(+), 24 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index f46022a..ed6a14b 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -189,9 +189,9 @@ eval = \case val <- interpret' e case val of VInt port -> do - (mvar, chan) <- liftIO $ NS.createServerNew port + (mvar, clientlist) <- liftIO $ NS.createServerNew port liftIO $ C.traceIO "Socket created" - return $ VServerSocket mvar chan $ show port + return $ VServerSocket mvar clientlist $ show port _ -> throw $ NotAnExpectedValueException "VInt" val Accept e t -> do @@ -199,8 +199,9 @@ eval = \case val <- interpret' e case val of - VServerSocket mvar chan ownport -> do - newuser <- liftIO $ Chan.readChan chan + VServerSocket mvar clientlist ownport -> do + -- newuser <- liftIO $ Chan.readChan chan + newuser <- liftIO $ NS.findFittingClient clientlist t liftIO $ C.traceIO "Client accepted" networkconnectionmap <- liftIO $ MVar.readMVar mvar case Map.lookup newuser networkconnectionmap of diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 31e84ce..2d8a807 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -16,6 +16,7 @@ import qualified ValueParsing.ValueGrammar as VG import qualified Networking.Common as NC import qualified Networking.Serialize as NSerialize import ProcessEnvironment +import qualified Syntax import Control.Exception import qualified Networking.UserID as UserID @@ -27,8 +28,9 @@ import Networking.NetworkConnection import qualified Control.Concurrent as MVar import Networking.NetworkConnection (newNetworkConnection, NetworkConnection (ncConnectionState, ncOwnUserID)) import Networking.Messages (Messages(Introduce, RequestSync, SyncIncoming)) +import qualified Control.Concurrent as MVar -createServerNew :: Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), Chan.Chan String) +createServerNew :: Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), MVar.MVar [(String, Syntax.Type)]) createServerNew port = do serverid <- UserID.newRandomUserID sock <- liftIO $ socket AF_INET Stream 0 @@ -38,28 +40,30 @@ createServerNew port = do , addrSocketType = Stream } addrInfo <- liftIO $ getAddrInfo (Just hints) Nothing $ Just $ show port - + liftIO $ bind sock $ addrAddress $ head addrInfo liftIO $ listen sock 2 mvar <- MVar.newEmptyMVar MVar.putMVar mvar Map.empty - chan <- Chan.newChan - forkIO $ acceptClientsNew mvar chan sock - return (mvar, chan) - -acceptClientsNew :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> Chan.Chan String -> Socket -> IO () -acceptClientsNew mvar chan socket = do + -- chan <- Chan.newChan + clientlist <- MVar.newEmptyMVar + MVar.putMVar clientlist [] + forkIO $ acceptClientsNew mvar clientlist sock + return (mvar, clientlist) + +acceptClientsNew :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> Socket -> IO () +acceptClientsNew mvar clientlist socket = do putStrLn "Waiting for clients" clientsocket <- accept socket putStrLn "Accepted new client" - forkIO $ acceptClientNew mvar chan clientsocket - acceptClientsNew mvar chan socket + forkIO $ acceptClientNew mvar clientlist clientsocket + acceptClientsNew mvar clientlist socket -- In the nothing case we shoud wait a few seconds for other messages to resolve the issue -acceptClientNew :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> Chan.Chan String -> (Socket, SockAddr) -> IO () -acceptClientNew mvar chan clientsocket = do +acceptClientNew :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> IO () +acceptClientNew mvar clientlist clientsocket = do hdl <- NC.getHandle $ fst clientsocket message <- hGetLine hdl putStrLn $ "Recieved message:" ++ message @@ -92,13 +96,16 @@ acceptClientNew mvar chan clientsocket = do let newnetworkconnectionmap = Map.insert userid networkconnection networkconnectionmap MVar.putMVar mvar newnetworkconnectionmap NC.sendMessage (Introduce serverid) hdl -- Answer with own serverid - Chan.writeChan chan userid -- Adds the new user to the users that can be accepted by the server + -- Chan.writeChan chan userid + -- Adds the new user to the users that can be accepted by the server + clientlistraw <- MVar.takeMVar clientlist + MVar.putMVar clientlist $ clientlistraw ++ [(userid, syntype)] - _ -> do + _ -> do putStrLn "Error during recieving a networkmessage: only ipv4 is currently supported!" MVar.putMVar mvar networkconnectionmap - + ChangePartnerAddress userid hostname port -> do networkconnectionmap <- MVar.takeMVar mvar case Map.lookup userid networkconnectionmap of @@ -139,7 +146,7 @@ acceptClientNew mvar chan clientsocket = do hostaddressTypeToString :: HostAddress -> String -hostaddressTypeToString hostaddress = do +hostaddressTypeToString hostaddress = do let (a, b, c, d) = hostAddressToTuple hostaddress show a ++ "." ++ show b ++ "."++ show c ++ "." ++ show d @@ -147,13 +154,38 @@ waitForIntroduction :: Handle -> String -> IO String waitForIntroduction handle serverid = do message <- hGetLine handle case VT.runAlex message VG.parseMessages of - Left err -> do + Left err -> do putStrLn $ "Error during client introduction: "++err throw $ NC.NoIntroductionException message Right deserial -> case deserial of Introduce partner -> do NC.sendMessage (Messages.Introduce serverid) handle return partner - _ -> do + _ -> do putStrLn $ "Error during client introduction, wrong message: "++ message - throw $ NC.NoIntroductionException message \ No newline at end of file + throw $ NC.NoIntroductionException message + +findFittingClientMaybe :: MVar.MVar [(String, Syntax.Type)] -> Syntax.Type -> IO (Maybe String) +findFittingClientMaybe clientlist desiredType = do + clientlistraw <- MVar.takeMVar clientlist + let newclientlistrawAndReturn = fFCMRaw clientlistraw desiredType + putStrLn "findFittingClientMaybe:" + print clientlistraw + putStrLn $ "Desired Type: " ++ show desiredType + -- For some reason these prints are needed for it to work. Probably some timing thing + MVar.putMVar clientlist $ fst newclientlistrawAndReturn + return $ snd newclientlistrawAndReturn + where + fFCMRaw :: [(String, Syntax.Type)] -> Syntax.Type -> ([(String, Syntax.Type)], Maybe String) + fFCMRaw [] _ = ([], Nothing) + fFCMRaw (x:xs) desiredtype = if snd x == Syntax.dualof desiredtype then (xs, Just $ fst x) else do + let nextfFCMRaw = fFCMRaw xs desiredtype + (x:(fst nextfFCMRaw), snd nextfFCMRaw) + +-- This halts until a fitting client is found +findFittingClient :: MVar.MVar [(String, Syntax.Type)] -> Syntax.Type -> IO String +findFittingClient clientlist desiredType = do + mbystring <- findFittingClientMaybe clientlist desiredType + case mbystring of + Just userid -> return userid + Nothing -> findFittingClient clientlist desiredType \ No newline at end of file diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index cd421df..1630757 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -63,7 +63,7 @@ data Value | VFuncCast Value FuncType FuncType -- (Value : (ρ,α,Π(x:A)A') => (ρ,α,Π(x:B)B')) | VRec PEnv String String Exp Exp | VNewNatRec PEnv String String String Type Exp String Exp - | VServerSocket (MVar.MVar (Map.Map String (NCon.NetworkConnection Value))) (C.Chan String) String + | VServerSocket (MVar.MVar (Map.Map String (NCon.NetworkConnection Value))) (MVar.MVar [(String, Type)]) String -- Own Port Number deriving Eq From 9895eedb08317a25a4293b4dd337dd105ab9490c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 14 Dec 2022 14:33:16 +0100 Subject: [PATCH 057/229] Update Server.hs --- src/Networking/Server.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 2d8a807..60569c9 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -3,12 +3,12 @@ module Networking.Server where import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.Chan as Chan -import Control.Concurrent (forkIO) import Control.Monad.IO.Class import qualified Data.Map as Map import qualified Data.Maybe import GHC.IO.Handle import Network.Socket +import Control.Concurrent import Networking.Messages import qualified ValueParsing.ValueTokens as VT @@ -169,10 +169,11 @@ findFittingClientMaybe :: MVar.MVar [(String, Syntax.Type)] -> Syntax.Type -> IO findFittingClientMaybe clientlist desiredType = do clientlistraw <- MVar.takeMVar clientlist let newclientlistrawAndReturn = fFCMRaw clientlistraw desiredType - putStrLn "findFittingClientMaybe:" - print clientlistraw - putStrLn $ "Desired Type: " ++ show desiredType + -- putStrLn "findFittingClientMaybe:" + -- print clientlistraw + -- putStrLn $ "Desired Type: " ++ show desiredType -- For some reason these prints are needed for it to work. Probably some timing thing + -- Also we send the name of the type but not the type itself, this needs to change MVar.putMVar clientlist $ fst newclientlistrawAndReturn return $ snd newclientlistrawAndReturn where @@ -188,4 +189,6 @@ findFittingClient clientlist desiredType = do mbystring <- findFittingClientMaybe clientlist desiredType case mbystring of Just userid -> return userid - Nothing -> findFittingClient clientlist desiredType \ No newline at end of file + Nothing -> do + threadDelay 10000 -- Sleep for 10 ms to not hammer the CPU + findFittingClient clientlist desiredType \ No newline at end of file From 2c236476d0aa569b087f79088a103a787bae0f83 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 14 Dec 2022 19:47:11 +0100 Subject: [PATCH 058/229] Added a way to convert VChanSerial to VChan --- src/Networking/Client.hs | 2 +- src/Networking/Common.hs | 41 +++++++++++++++++++++++++++-- src/Networking/NetworkConnection.hs | 15 ++++++++++- src/Networking/Serialize.hs | 2 +- 4 files changed, 55 insertions(+), 5 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index a7b856f..49f88e6 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -42,7 +42,7 @@ sendMessage networkconnection val = do putStrLn "After connect" handle <- NC.getHandle clientsocket putStrLn "Client connected: Sending Message" - valcleaned <- makeVChanSendable hostname port val + valcleaned <- makeVChanSendable hostname port val -- This sends a ChangeNetworkPartner Message if appropriate NC.sendMessage (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) valcleaned) handle DC.writeMessage (ncWrite networkconnection) valcleaned putStrLn "Disabling Chans" diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index f3409d0..50b8769 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -24,8 +24,8 @@ import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG import qualified Networking.DirectionalConnection as DC import Networking.DirectionalConnection (DirectionalConnection) -import Networking.Serialize (Serializable) -import Networking.NetworkConnection (createNetworkConnection, createNetworkConnectionS) +import Networking.Serialize (Serializable (serialize)) +import Networking.NetworkConnection (createNetworkConnection, createNetworkConnectionS, serializeNetworkConnection) newtype ServerException = NoIntroductionException String deriving Eq @@ -119,5 +119,42 @@ replaceVChanSerial input = case input of rest <- replaceVChanSerialPEnv xs return $ (fst x, newval):rest +replaceVChan :: Value -> IO Value +replaceVChan input = case input of + VSend v -> do + nv <- replaceVChan v + return $ VSend nv + VPair v1 v2 -> do + nv1 <- replaceVChan v1 + nv2 <- replaceVChan v2 + return $ VPair nv1 nv2 + VFunc penv a b -> do + newpenv <- replaceVChanPEnv penv + return $ VFunc newpenv a b + VDynCast v g -> do + nv <- replaceVChan v + return $ VDynCast nv g + VFuncCast v a b -> do + nv <- replaceVChan v + return $ VFuncCast nv a b + VRec penv a b c d -> do + newpenv <- replaceVChanPEnv penv + return $ VRec newpenv a b c d + VNewNatRec penv a b c d e f g -> do + newpenv <- replaceVChanPEnv penv + return $ VNewNatRec newpenv a b c d e f g + VChan nc -> do + putStrLn "Attempting to serialize a VChan" + (r, rl, w, wl, pid, oid, h, p) <- serializeNetworkConnection nc + return $ VChanSerial (r, rl) (w, wl) pid oid (h, p) + _ -> return input + where + replaceVChanPEnv :: [(String, Value)] -> IO [(String, Value)] + replaceVChanPEnv [] = return [] + replaceVChanPEnv (x:xs) = do + newval <- replaceVChan $ snd x + rest <- replaceVChanPEnv xs + return $ (fst x, newval):rest + -- openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) openSocketNC addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) \ No newline at end of file diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index 1f3e81c..cc4aa79 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -1,6 +1,7 @@ module Networking.NetworkConnection where import Networking.DirectionalConnection +import qualified Data.Maybe import qualified Control.Concurrent.MVar as MVar data NetworkConnection a = NetworkConnection {ncRead :: DirectionalConnection a, ncWrite :: DirectionalConnection a, ncPartnerUserID :: Maybe String, ncOwnUserID :: Maybe String, ncConnectionState :: MVar.MVar ConnectionState} @@ -9,6 +10,7 @@ data NetworkConnection a = NetworkConnection {ncRead :: DirectionalConnection a, data ConnectionState = Connected {csHostname :: String, csPort :: String} | Disconnected | Emulated + | RedirectRequest {csHostname :: String, csPort :: String} -- Asks to redirect to this connection deriving Eq @@ -38,4 +40,15 @@ newEmulatedConnection :: DirectionalConnection a -> DirectionalConnection a -> I newEmulatedConnection r w = do connectionstate <- MVar.newEmptyMVar MVar.putMVar connectionstate Emulated - return $ NetworkConnection r w Nothing Nothing connectionstate \ No newline at end of file + return $ NetworkConnection r w Nothing Nothing connectionstate + +serializeNetworkConnection :: NetworkConnection a -> IO ([a], Int, [a], Int, String, String, String, String) +serializeNetworkConnection nc = do + constate <- MVar.readMVar $ ncConnectionState nc + (readList, readUnread) <- serializeConnection $ ncRead nc + (writeList, writeUnread) <- serializeConnection $ ncWrite nc + (address, port) <- case constate of + Connected address port -> return (address, port) + RedirectRequest address port -> return (address, port) + _ -> return ("", "") + return (readList, readUnread, writeList, writeUnread, Data.Maybe.fromMaybe "" $ ncPartnerUserID nc, Data.Maybe.fromMaybe "" $ ncPartnerUserID nc, "", "") \ No newline at end of file diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index dba1127..c3f3f9a 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -50,7 +50,7 @@ instance Serializable Messages where -- instance (Serializable a => Serializable (NCon.NetworkConnection a)) where instance Serializable (NCon.NetworkConnection Value) where serialize con = do - constate <- MVar.takeMVar $ NCon.ncConnectionState con + constate <- MVar.readMVar $ NCon.ncConnectionState con (readList, readUnread) <- DC.serializeConnection $ NCon.ncRead con (writeList, writeUnread) <- DC.serializeConnection $ NCon.ncWrite con From da9e2378887a7a6c27fc39b6be47407c34a7970b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 15 Dec 2022 15:04:32 +0100 Subject: [PATCH 059/229] Client now adds redirection notice to redirected VChans --- dev-examples/handoff/client.ldgvnw | 8 ++--- dev-examples/handoff/handoff.ldgvnw | 6 ++-- dev-examples/handoff2/notes | 1 + src/Interpreter.hs | 11 +++++-- src/Networking/Client.hs | 49 ++++++++++++++++++++++++++--- src/Networking/NetworkConnection.hs | 2 +- src/Networking/Serialize.hs | 2 +- src/Networking/Server.hs | 20 ++++++------ 8 files changed, 75 insertions(+), 24 deletions(-) create mode 100644 dev-examples/handoff2/notes diff --git a/dev-examples/handoff/client.ldgvnw b/dev-examples/handoff/client.ldgvnw index 3fc0245..a4be60c 100644 --- a/dev-examples/handoff/client.ldgvnw +++ b/dev-examples/handoff/client.ldgvnw @@ -1,11 +1,11 @@ -- Simple example of Label-Dependent Session Types -- Interprets addition of two numbers -type SendTwoInt : ! ~ssn = !Int. !Int. Unit +type SendInt : ! ~ssn = !Int. !Int. Unit type SendOneInt : ! ~ssn = !Int. Unit type SendSendOneInt : ! ~ssn = !SendOneInt. Unit -val send1 (c: SendTwoInt) : SendOneInt = +val send1 (c: SendInt) : SendOneInt = let x = ((send c) 1) in (x) @@ -13,7 +13,7 @@ val send2 (c2: SendOneInt) = let y = ((send c2) 42) in () -val add2 (c1: dualof SendTwoInt) = +val add2 (c1: dualof SendInt) = let = recv c1 in let = recv c2 in (m + n) @@ -21,7 +21,7 @@ val add2 (c1: dualof SendTwoInt) = val main : Unit val main = let sock = (create 4141) in - let con = (connect sock SendTwoInt "127.0.0.1" 4242) in -- This cannot be localhost, since this might break on containerized images + let con = (connect sock SendInt "127.0.0.1" 4242) in -- This cannot be localhost, since this might break on containerized images let oneint = (send1 con) in let con2 = (connect sock SendSendOneInt "127.0.0.1" 4343) in (send con2) oneint diff --git a/dev-examples/handoff/handoff.ldgvnw b/dev-examples/handoff/handoff.ldgvnw index 75676a9..149b49b 100644 --- a/dev-examples/handoff/handoff.ldgvnw +++ b/dev-examples/handoff/handoff.ldgvnw @@ -1,11 +1,11 @@ -- Simple example of Label-Dependent Session Types -- Interprets addition of two numbers -type SendTwoInt : ! ~ssn = !Int. !Int. Unit +type SendInt : ! ~ssn = !Int. !Int. Unit type SendOneInt : ! ~ssn = !Int. Unit type SendSendOneInt : ! ~ssn = !SendOneInt. Unit -val send1 (c: SendTwoInt) : SendOneInt = +val send1 (c: SendInt) : SendOneInt = let x = ((send c) 1) in (x) @@ -13,7 +13,7 @@ val send2 (c2: SendOneInt) = let y = ((send c2) 42) in () -val add2 (c1: dualof SendTwoInt) = +val add2 (c1: dualof SendInt) = let = recv c1 in let = recv c2 in (m + n) diff --git a/dev-examples/handoff2/notes b/dev-examples/handoff2/notes new file mode 100644 index 0000000..83206c0 --- /dev/null +++ b/dev-examples/handoff2/notes @@ -0,0 +1 @@ +There is a race condition when the client and server is already offline when the handoff wants data \ No newline at end of file diff --git a/src/Interpreter.hs b/src/Interpreter.hs index ed6a14b..ed73654 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -173,10 +173,14 @@ eval = \case return $ VPair (VChan nc1) $ VChan nc2 Send e -> VSend <$> interpret' e -- Apply VSend to the output of interpret' e Recv e -> do + liftIO $ putStrLn "Recieving value" interpret' e >>= \v@(VChan ci) -> do let dcRead = NCon.ncRead ci + liftIO $ putStrLn "Trying to read new value" valunclean <- liftIO $ DC.readUnreadMessage dcRead + liftIO $ putStrLn "Read new value" val <- liftIO $ NC.replaceVChanSerial valunclean + liftIO $ putStrLn "Replaced Serial" liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e -- Disable the old channel and get a new one @@ -201,12 +205,15 @@ eval = \case case val of VServerSocket mvar clientlist ownport -> do -- newuser <- liftIO $ Chan.readChan chan - newuser <- liftIO $ NS.findFittingClient clientlist t + liftIO $ C.traceIO "Searching for correct communicationpartner" + newuser <- liftIO $ NS.findFittingClient clientlist t -- There is still an issue liftIO $ C.traceIO "Client accepted" networkconnectionmap <- liftIO $ MVar.readMVar mvar case Map.lookup newuser networkconnectionmap of Nothing -> throw $ CommunicationPartnerNotFoundException newuser - Just networkconnection -> return $ VChan networkconnection + Just networkconnection -> do + liftIO $ C.traceIO "Client successfully accepted!" + return $ VChan networkconnection _ -> throw $ NotAnExpectedValueException "VServerSocket" val Connect e0 t e1 e2-> do diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 49f88e6..d59a14f 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -22,6 +22,7 @@ import qualified Control.Concurrent as MVar import Control.Exception import GHC.Exception import qualified Syntax +import qualified Networking.NetworkConnection as NCon sendMessage :: NetworkConnection Value -> Value -> IO () sendMessage networkconnection val = do @@ -42,9 +43,13 @@ sendMessage networkconnection val = do putStrLn "After connect" handle <- NC.getHandle clientsocket putStrLn "Client connected: Sending Message" - valcleaned <- makeVChanSendable hostname port val -- This sends a ChangeNetworkPartner Message if appropriate + -- valcleaned <- makeVChanSendable hostname port val -- This sends a ChangeNetworkPartner Message if appropriate + valcleaned <- NC.replaceVChan val NC.sendMessage (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) valcleaned) handle DC.writeMessage (ncWrite networkconnection) valcleaned + putStrLn "Sending message to old communication partner" + sendVChanMessages hostname port val -- This sends a ChangeNetworkPartner Message if appropriate + putStrLn "Disabling Chans" disableVChans val -- Disables all sent VChans for the sending party putStrLn "Chans disabled" @@ -90,8 +95,7 @@ initialConnect mvar hostname port ownport syntype= do let hints = defaultHints { addrFlags = [] , addrSocketType = Stream - } - networkconnectionmap <- MVar.takeMVar mvar + } addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port clientsocket <- NC.openSocketNC $ head addrInfo connect clientsocket $ addrAddress $ head addrInfo @@ -104,12 +108,48 @@ initialConnect mvar hostname port ownport syntype= do hClose handle newConnection <- newNetworkConnection introductionanswer ownuserid hostname port + networkconnectionmap <- MVar.takeMVar mvar let newNetworkconnectionmap = Map.insert introductionanswer newConnection networkconnectionmap MVar.putMVar mvar newNetworkconnectionmap return $ VChan newConnection -- openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) +sendVChanMessages :: String -> String -> Value -> IO () +sendVChanMessages newhost newport input = case input of + VSend v -> sendVChanMessages newhost newport v + VPair v1 v2 -> do + sendVChanMessages newhost newport v1 + sendVChanMessages newhost newport v2 + VFunc penv a b -> sendVChanMessagesPEnv newhost newport penv + VDynCast v g -> sendVChanMessages newhost newport v + VFuncCast v a b -> sendVChanMessages newhost newport v + VRec penv a b c d -> sendVChanMessagesPEnv newhost newport penv + VNewNatRec penv a b c d e f g -> sendVChanMessagesPEnv newhost newport penv + VChan nc -> do + putStrLn "Attempting to sending ChangePartnerAddress" + -- connectionstate <- MVar.readMVar $ ncConnectionState nc + -- putStrLn "Aquired connectionstate" + sendNetworkMessage nc (Messages.ChangePartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID nc) newhost newport) + -- MVar.putMVar (ncConnectionState nc) Disconnected + -- _ <- MVar.takeMVar $ ncConnectionState nc + -- MVar.putMVar (ncConnectionState nc) Disconnected + putStrLn "Sent ChangePartnerAddress" + _ <- MVar.takeMVar $ ncConnectionState nc + putStrLn "Got connectionstate - Changeing to redirect" + MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest newhost newport + putStrLn "Set RedirectRequest" + _ -> return () + where + sendVChanMessagesPEnv :: String -> String -> [(String, Value)] -> IO () + sendVChanMessagesPEnv _ _ [] = return () + sendVChanMessagesPEnv newhost newport (x:xs) = do + sendVChanMessages newhost newport $ snd x + sendVChanMessagesPEnv newhost newport xs + + + +{- makeVChanSendable :: String -> String -> Value -> IO Value makeVChanSendable newhost newport input = case input of VSend v -> do @@ -151,4 +191,5 @@ makeVChanSendable newhost newport input = case input of makeVChanSendablePEnv newhost newport (x:xs) = do newval <- makeVChanSendable newhost newport $ snd x rest <- makeVChanSendablePEnv newhost newport xs - return $ (fst x, newval):rest \ No newline at end of file + return $ (fst x, newval):rest +-} \ No newline at end of file diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index cc4aa79..ef9d2b3 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -51,4 +51,4 @@ serializeNetworkConnection nc = do Connected address port -> return (address, port) RedirectRequest address port -> return (address, port) _ -> return ("", "") - return (readList, readUnread, writeList, writeUnread, Data.Maybe.fromMaybe "" $ ncPartnerUserID nc, Data.Maybe.fromMaybe "" $ ncPartnerUserID nc, "", "") \ No newline at end of file + return (readList, readUnread, writeList, writeUnread, Data.Maybe.fromMaybe "" $ ncPartnerUserID nc, Data.Maybe.fromMaybe "" $ ncOwnUserID nc, address, port) \ No newline at end of file diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index c3f3f9a..a0440f0 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -92,7 +92,7 @@ instance Serializable Value where VServerSocket {} -> throw $ UnserializableException "VServerSocket" VChan nc -> serializeLabeledEntry "VChan" nc - VChanSerial r w p o c -> serializeLabeledEntryMulti "VChanSerial" r $ sNext w $ sNext p $ sNext c $ sLast c + VChanSerial r w p o c -> serializeLabeledEntryMulti "VChanSerial" r $ sNext w $ sNext p $ sNext o $ sLast c -- VChan {} -> throw $ UnserializableException "VChan" {-VChan cc -> do putStrLn "Trying to serialize VChan" diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 60569c9..ceb5eee 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -72,16 +72,16 @@ acceptClientNew mvar clientlist clientsocket = do Left err -> putStrLn $ "Error during recieving a networkmessage: "++err Right deserialmessages -> case deserialmessages of NewValue userid val -> do - networkconnectionmap <- MVar.takeMVar mvar + networkconnectionmap <- MVar.readMVar mvar case Map.lookup userid networkconnectionmap of Just networkconnection -> do -- This means we habe already spoken to this client -- valCleaned <- NC.replaceVChanSerial val -- Replaces VChanSerial with VChans and their appropriate connection -- ND.writeMessage (ncRead networkconnection) valCleaned ND.writeMessage (ncRead networkconnection) val - MVar.putMVar mvar networkconnectionmap + -- MVar.putMVar mvar networkconnectionmap Nothing -> do putStrLn "Error during recieving a networkmessage: Introduction is needed prior to sending values!" - MVar.putMVar mvar networkconnectionmap + -- MVar.putMVar mvar networkconnectionmap IntroduceClient userid clientport syntype-> do networkconnectionmap <- MVar.takeMVar mvar case Map.lookup userid networkconnectionmap of @@ -122,23 +122,25 @@ acceptClientNew mvar clientlist clientsocket = do Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that RequestSync userid -> do - networkconnectionmap <- MVar.takeMVar mvar + networkconnectionmap <- MVar.readMVar mvar case Map.lookup userid networkconnectionmap of Just networkconnection -> do -- Change to current network address - MVar.putMVar mvar networkconnectionmap + -- MVar.putMVar mvar networkconnectionmap -- Sync and request sync writevals <- ND.allMessages $ ncWrite networkconnection NClient.sendNetworkMessage networkconnection (SyncIncoming (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) writevals) - Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that + -- Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that + Nothing -> return () SyncIncoming userid values -> do - networkconnectionmap <- MVar.takeMVar mvar + networkconnectionmap <- MVar.readMVar mvar case Map.lookup userid networkconnectionmap of Just networkconnection -> do -- Change to current network address - MVar.putMVar mvar networkconnectionmap + -- MVar.putMVar mvar networkconnectionmap ND.syncMessages (ncRead networkconnection) values - Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that + -- Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that + Nothing -> return () _ -> do serial <- NSerialize.serialize deserialmessages putStrLn $ "Error unsupported networkmessage: "++ serial From a497c235925662d8b16f2358ca334a12981b33ae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Fri, 16 Dec 2022 15:34:19 +0100 Subject: [PATCH 060/229] Added message redirection --- src/Interpreter.hs | 2 +- src/Networking/Client.hs | 110 ++++++++++------- src/Networking/Common.hs | 9 ++ src/Networking/Messages.hs | 20 ++++ src/Networking/Serialize.hs | 6 + src/Networking/Server.hs | 201 +++++++++++++++++++------------- src/ValueParsing/ValueGrammar.y | 8 +- src/ValueParsing/ValueTokens.x | 4 + 8 files changed, 233 insertions(+), 127 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index ed73654..93f0084 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -193,7 +193,7 @@ eval = \case val <- interpret' e case val of VInt port -> do - (mvar, clientlist) <- liftIO $ NS.createServerNew port + (mvar, clientlist) <- liftIO $ NS.createServer port liftIO $ C.traceIO "Socket created" return $ VServerSocket mvar clientlist $ show port _ -> throw $ NotAnExpectedValueException "VInt" val diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index d59a14f..632edda 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -23,68 +23,94 @@ import Control.Exception import GHC.Exception import qualified Syntax import qualified Networking.NetworkConnection as NCon +import qualified Networking.Common as NC sendMessage :: NetworkConnection Value -> Value -> IO () sendMessage networkconnection val = do - let hints = defaultHints { - addrFlags = [] - , addrSocketType = Stream - } connectionstate <- MVar.takeMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port -> do - catch ( do - putStrLn $ "Trying to connect to: " ++ hostname ++":"++port - addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port - --addrInfo <- getAddrInfo (Just hints) (Just "127.0.0.1") $ Just port -- Thia is obviously only for testing - clientsocket <- NC.openSocketNC $ head addrInfo - putStrLn "Before connect" - connect clientsocket $ addrAddress $ head addrInfo - putStrLn "After connect" - handle <- NC.getHandle clientsocket - putStrLn "Client connected: Sending Message" - -- valcleaned <- makeVChanSendable hostname port val -- This sends a ChangeNetworkPartner Message if appropriate - valcleaned <- NC.replaceVChan val - NC.sendMessage (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) valcleaned) handle - DC.writeMessage (ncWrite networkconnection) valcleaned - putStrLn "Sending message to old communication partner" - sendVChanMessages hostname port val -- This sends a ChangeNetworkPartner Message if appropriate - - putStrLn "Disabling Chans" - disableVChans val -- Disables all sent VChans for the sending party - putStrLn "Chans disabled" - hClose handle ) $ printConErr hostname port + catch (tryToSend networkconnection hostname port val) $ printConErr hostname port NCon.Disconnected -> putStrLn "Error when sending message: This channel is disconnected" NCon.Emulated -> DC.writeMessage (ncWrite networkconnection) val MVar.putMVar (ncConnectionState networkconnection) connectionstate +tryToSend :: NetworkConnection Value -> String -> String -> Value -> IO () +tryToSend networkconnection hostname port val = do + let hints = defaultHints { + addrFlags = [] + , addrSocketType = Stream + } + putStrLn $ "Trying to connect to: " ++ hostname ++":"++port + addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port + --addrInfo <- getAddrInfo (Just hints) (Just "127.0.0.1") $ Just port -- Thia is obviously only for testing + clientsocket <- NC.openSocketNC $ head addrInfo + -- putStrLn "Before connect" + connect clientsocket $ addrAddress $ head addrInfo + -- putStrLn "After connect" + handle <- NC.getHandle clientsocket + putStrLn "Client connected: Sending Message" + -- valcleaned <- makeVChanSendable hostname port val -- This sends a ChangeNetworkPartner Message if appropriate + valcleaned <- NC.replaceVChan val + NC.sendMessage (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) valcleaned) handle + DC.writeMessage (ncWrite networkconnection) valcleaned + -- putStrLn "Sending message to old communication partner" + sendVChanMessages hostname port val -- This sends a ChangeNetworkPartner Message if appropriate + + -- putStrLn "Disabling Chans" + disableVChans val -- Disables all sent VChans for the sending party + -- putStrLn "Chans disabled" + putStrLn "Waiting for response" + mbyresponse <- NC.recieveResponse handle + hClose handle + case mbyresponse of + Just response -> case response of + Okay -> putStrLn "Message okay" + Redirect host port -> do + putStrLn "Communication partner changed address, resending" + tryToSend networkconnection host port val + Nothing -> putStrLn "Error when recieving response" + + + sendNetworkMessage :: NetworkConnection Value -> Messages -> IO () sendNetworkMessage networkconnection message = do - let hints = defaultHints { - addrFlags = [] - , addrSocketType = Stream - } connectionstate <- MVar.takeMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port -> do - catch ( do - putStrLn $ "Trying to connect to: " ++ hostname ++":"++port - addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port - --addrInfo <- getAddrInfo (Just hints) (Just "127.0.0.1") $ Just port -- Thia is obviously only for testing - clientsocket <- NC.openSocketNC $ head addrInfo - putStrLn "Before connect" - connect clientsocket $ addrAddress $ head addrInfo - putStrLn "After connect" - handle <- NC.getHandle clientsocket - putStrLn "Client connected: Sending NetworkMessage" - NC.sendMessage message handle - hClose handle ) $ printConErr hostname port + catch ( tryToSendNetworkMessage networkconnection hostname port message ) $ printConErr hostname port NCon.Disconnected -> putStrLn "Error when sending message: This channel is disconnected" NCon.Emulated -> pure () MVar.putMVar (ncConnectionState networkconnection) connectionstate - +tryToSendNetworkMessage :: NetworkConnection Value -> String -> String -> Messages -> IO () +tryToSendNetworkMessage networkconnection hostname port message = do + let hints = defaultHints { + addrFlags = [] + , addrSocketType = Stream + } + putStrLn $ "Trying to connect to: " ++ hostname ++":"++port + addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port + --addrInfo <- getAddrInfo (Just hints) (Just "127.0.0.1") $ Just port -- Thia is obviously only for testing + clientsocket <- NC.openSocketNC $ head addrInfo + putStrLn "Before connect" + connect clientsocket $ addrAddress $ head addrInfo + putStrLn "After connect" + handle <- NC.getHandle clientsocket + putStrLn "Client connected: Sending NetworkMessage" + NC.sendMessage message handle + + putStrLn "Waiting for response" + mbyresponse <- NC.recieveResponse handle + hClose handle + case mbyresponse of + Just response -> case response of + Okay -> putStrLn "Message okay" + Redirect host port -> do + putStrLn "Communication partner changed address, resending" + tryToSendNetworkMessage networkconnection host port message + Nothing -> putStrLn "Error when recieving response" printConErr :: String -> String -> IOException -> IO () printConErr hostname port err = putStrLn $ "Communication Partner " ++ hostname ++ ":" ++ port ++ "not found!" diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 50b8769..b295200 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -52,6 +52,15 @@ recieveMessage handle = do return Nothing Right deserialmessage -> return $ Just deserialmessage +recieveResponse :: Handle -> IO (Maybe Responses) +recieveResponse handle = do + message <- hGetLine handle + case VT.runAlex message VG.parseResponses of + Left err -> do + putStrLn $ "Error during recieving a networkmessage: "++err + return Nothing + Right deserialmessage -> return $ Just deserialmessage + getHandle :: Socket -> IO Handle diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs index d0cd96f..0444f6e 100644 --- a/src/Networking/Messages.hs +++ b/src/Networking/Messages.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + module Networking.Messages where import ProcessEnvironment @@ -7,6 +9,7 @@ type Partner = String type Hostname = String type Port = String +-- I need to add the Port to every introduction so I can answer oder alles muss mit einem okay quitiert werden, dann kann die antwort gesendet werden data Messages = Introduce Partner | IntroduceClient Partner Port Type @@ -16,3 +19,20 @@ data Messages | RequestSync Partner | ChangePartnerAddress Partner Hostname Port deriving Eq + +data Responses + = Redirect Hostname Port + | Okay + +getPartnerID :: Messages -> String +getPartnerID = \case + Introduce p -> p + IntroduceClient p _ _ -> p + IntroduceServer p -> p + NewValue p _ -> p + SyncIncoming p _ -> p + RequestSync p -> p + ChangePartnerAddress p _ _ -> p + + + diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index a0440f0..ddb2d40 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -37,6 +37,12 @@ instance Exception SerializationException class Serializable a where serialize :: a -> IO String + +instance Serializable Responses where + serialize = \case + Redirect host port -> serializeLabeledEntryMulti "NRedirect" host $ sLast port + Okay -> return "NOkay" + instance Serializable Messages where serialize = \case Introduce p -> serializeLabeledEntry "NIntroduce" p diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index ceb5eee..b5fb9ea 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -29,9 +29,11 @@ import qualified Control.Concurrent as MVar import Networking.NetworkConnection (newNetworkConnection, NetworkConnection (ncConnectionState, ncOwnUserID)) import Networking.Messages (Messages(Introduce, RequestSync, SyncIncoming)) import qualified Control.Concurrent as MVar +import qualified Control.Concurrent as MVar +import qualified Networking.Common as NC -createServerNew :: Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), MVar.MVar [(String, Syntax.Type)]) -createServerNew port = do +createServer :: Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), MVar.MVar [(String, Syntax.Type)]) +createServer port = do serverid <- UserID.newRandomUserID sock <- liftIO $ socket AF_INET Stream 0 liftIO $ setSocketOption sock ReuseAddr 1 @@ -48,104 +50,137 @@ createServerNew port = do -- chan <- Chan.newChan clientlist <- MVar.newEmptyMVar MVar.putMVar clientlist [] - forkIO $ acceptClientsNew mvar clientlist sock + forkIO $ acceptClients mvar clientlist sock return (mvar, clientlist) -acceptClientsNew :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> Socket -> IO () -acceptClientsNew mvar clientlist socket = do +acceptClients :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> Socket -> IO () +acceptClients mvar clientlist socket = do putStrLn "Waiting for clients" clientsocket <- accept socket putStrLn "Accepted new client" - forkIO $ acceptClientNew mvar clientlist clientsocket - acceptClientsNew mvar clientlist socket + forkIO $ acceptClient mvar clientlist clientsocket + acceptClients mvar clientlist socket -- In the nothing case we shoud wait a few seconds for other messages to resolve the issue -acceptClientNew :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> IO () -acceptClientNew mvar clientlist clientsocket = do +acceptClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> IO () +acceptClient mvar clientlist clientsocket = do hdl <- NC.getHandle $ fst clientsocket message <- hGetLine hdl putStrLn $ "Recieved message:" ++ message case VT.runAlex message VG.parseMessages of -- case VT.runAlex message VG.parseValues of Left err -> putStrLn $ "Error during recieving a networkmessage: "++err - Right deserialmessages -> case deserialmessages of - NewValue userid val -> do - networkconnectionmap <- MVar.readMVar mvar - case Map.lookup userid networkconnectionmap of - Just networkconnection -> do -- This means we habe already spoken to this client - -- valCleaned <- NC.replaceVChanSerial val -- Replaces VChanSerial with VChans and their appropriate connection - -- ND.writeMessage (ncRead networkconnection) valCleaned - ND.writeMessage (ncRead networkconnection) val - -- MVar.putMVar mvar networkconnectionmap - Nothing -> do - putStrLn "Error during recieving a networkmessage: Introduction is needed prior to sending values!" - -- MVar.putMVar mvar networkconnectionmap - IntroduceClient userid clientport syntype-> do - networkconnectionmap <- MVar.takeMVar mvar - case Map.lookup userid networkconnectionmap of - Just networkconnection -> do - putStrLn "Error during recieving a networkmessage: Already introduced to this client!" - MVar.putMVar mvar networkconnectionmap - Nothing -> case snd clientsocket of -- This client is new - SockAddrInet port hostname -> do - serverid <- UserID.newRandomUserID - -- networkconnection <- newNetworkConnection userid serverid (show hostname) clientport - networkconnection <- newNetworkConnection userid serverid (hostaddressTypeToString hostname) clientport - let newnetworkconnectionmap = Map.insert userid networkconnection networkconnectionmap - MVar.putMVar mvar newnetworkconnectionmap - NC.sendMessage (Introduce serverid) hdl -- Answer with own serverid - -- Chan.writeChan chan userid - -- Adds the new user to the users that can be accepted by the server - clientlistraw <- MVar.takeMVar clientlist - MVar.putMVar clientlist $ clientlistraw ++ [(userid, syntype)] - - _ -> do - putStrLn "Error during recieving a networkmessage: only ipv4 is currently supported!" - MVar.putMVar mvar networkconnectionmap - - - ChangePartnerAddress userid hostname port -> do - networkconnectionmap <- MVar.takeMVar mvar - case Map.lookup userid networkconnectionmap of - Just networkconnection -> do -- Change to current network address - let constate = ncConnectionState networkconnection - _ <- MVar.takeMVar constate - MVar.putMVar constate $ Networking.NetworkConnection.Connected hostname port - MVar.putMVar mvar networkconnectionmap - - -- Sync and request sync - NClient.sendNetworkMessage networkconnection (RequestSync $ Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) - writevals <- ND.allMessages $ ncWrite networkconnection - NClient.sendNetworkMessage networkconnection (SyncIncoming (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) writevals) - - Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that - RequestSync userid -> do - networkconnectionmap <- MVar.readMVar mvar - case Map.lookup userid networkconnectionmap of - Just networkconnection -> do -- Change to current network address - -- MVar.putMVar mvar networkconnectionmap - -- Sync and request sync - writevals <- ND.allMessages $ ncWrite networkconnection - NClient.sendNetworkMessage networkconnection (SyncIncoming (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) writevals) - - -- Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that - Nothing -> return () - SyncIncoming userid values -> do - networkconnectionmap <- MVar.readMVar mvar - case Map.lookup userid networkconnectionmap of - Just networkconnection -> do -- Change to current network address - -- MVar.putMVar mvar networkconnectionmap - ND.syncMessages (ncRead networkconnection) values - - -- Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that - Nothing -> return () - _ -> do - serial <- NSerialize.serialize deserialmessages - putStrLn $ "Error unsupported networkmessage: "++ serial + Right deserialmessages -> do + let userid = getPartnerID deserialmessages + netcon <- MVar.takeMVar mvar + redirectRequest <- checkRedirectRequest netcon userid + MVar.putMVar mvar netcon + if redirectRequest then sendRedirect hdl netcon userid else do + case deserialmessages of + NewValue userid val -> do + handleNewValue mvar userid val + IntroduceClient userid clientport syntype-> do + handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype + ChangePartnerAddress userid hostname port -> do + handleChangePartnerAddress mvar userid hostname port + RequestSync userid -> do + handleRequestSync mvar userid + SyncIncoming userid values -> do + handleSyncIncoming mvar userid values + _ -> do + serial <- NSerialize.serialize deserialmessages + putStrLn $ "Error unsupported networkmessage: "++ serial + NC.sendMessage Messages.Okay hdl hClose hdl +checkRedirectRequest :: Map.Map String (NetworkConnection Value) -> String -> IO Bool +checkRedirectRequest ncmap userid = case Map.lookup userid ncmap of + Nothing -> return False + Just networkconnection -> do + constate <- MVar.readMVar $ ncConnectionState networkconnection + case constate of + RedirectRequest _ _ -> return True + _ -> return False + + +sendRedirect :: Handle -> Map.Map String (NetworkConnection Value) -> String -> IO () +sendRedirect handle ncmap userid = case Map.lookup userid ncmap of + Nothing -> return () + Just networkconnection -> do + constate <- MVar.readMVar $ ncConnectionState networkconnection + case constate of + RedirectRequest host port -> NC.sendMessage (Messages.Redirect host port) handle + _ -> return () + + + +handleNewValue :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> Value -> IO () +handleNewValue mvar userid val = do + networkconnectionmap <- MVar.readMVar mvar + case Map.lookup userid networkconnectionmap of + Just networkconnection -> do + ND.writeMessage (ncRead networkconnection) val + Nothing -> do + putStrLn "Error during recieving a networkmessage: Introduction is needed prior to sending values!" + +handleIntroduceClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Syntax.Type -> IO () +handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype = do + networkconnectionmap <- MVar.takeMVar mvar + case Map.lookup userid networkconnectionmap of + Just networkconnection -> do + putStrLn "Error during recieving a networkmessage: Already introduced to this client!" + MVar.putMVar mvar networkconnectionmap + Nothing -> case snd clientsocket of -- This client is new + SockAddrInet port hostname -> do + serverid <- UserID.newRandomUserID + networkconnection <- newNetworkConnection userid serverid (hostaddressTypeToString hostname) clientport + let newnetworkconnectionmap = Map.insert userid networkconnection networkconnectionmap + MVar.putMVar mvar newnetworkconnectionmap + NC.sendMessage (Introduce serverid) hdl -- Answer with own serverid + -- Adds the new user to the users that can be accepted by the server + clientlistraw <- MVar.takeMVar clientlist + MVar.putMVar clientlist $ clientlistraw ++ [(userid, syntype)] + + _ -> do + putStrLn "Error during recieving a networkmessage: only ipv4 is currently supported!" + MVar.putMVar mvar networkconnectionmap + +handleChangePartnerAddress :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> IO () +handleChangePartnerAddress mvar userid hostname port = do + networkconnectionmap <- MVar.takeMVar mvar + case Map.lookup userid networkconnectionmap of + Just networkconnection -> do -- Change to current network address + let constate = ncConnectionState networkconnection + _ <- MVar.takeMVar constate + MVar.putMVar constate $ Networking.NetworkConnection.Connected hostname port + MVar.putMVar mvar networkconnectionmap + + -- Sync and request sync + NClient.sendNetworkMessage networkconnection (RequestSync $ Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) + writevals <- ND.allMessages $ ncWrite networkconnection + NClient.sendNetworkMessage networkconnection (SyncIncoming (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) writevals) + + Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that + +handleRequestSync :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> IO () +handleRequestSync mvar userid = do + networkconnectionmap <- MVar.readMVar mvar + case Map.lookup userid networkconnectionmap of + Just networkconnection -> do -- Change to current network address + writevals <- ND.allMessages $ ncWrite networkconnection + NClient.sendNetworkMessage networkconnection (SyncIncoming (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) writevals) + othing -> return () + +handleSyncIncoming :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> [Value] -> IO () +handleSyncIncoming mvar userid values = do + networkconnectionmap <- MVar.readMVar mvar + case Map.lookup userid networkconnectionmap of + Just networkconnection -> do -- Change to current network address + ND.syncMessages (ncRead networkconnection) values + Nothing -> return () + hostaddressTypeToString :: HostAddress -> String hostaddressTypeToString hostaddress = do diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index efbea3e..3a566db 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -1,5 +1,5 @@ { -module ValueParsing.ValueGrammar (parseValues, parseMessages) where +module ValueParsing.ValueGrammar (parseValues, parseMessages, parseResponses) where import Control.Monad import qualified Data.List as List @@ -23,6 +23,7 @@ import Networking.Messages %name parseValues Values %name parseMessages Messages +%name parseResponses Responses -- %name parseSStringTypeElement SStringTypeElement -- %name parseSStringTypeElements SStringTypeElements -- %name parseSStringTypeArray SStringTypeArray @@ -120,6 +121,8 @@ import Networking.Messages nsyncincoming { T _ T.NSyncIncoming } nrequestsync { T _ T.NRequestSync } nchangepartneraddress {T _ T.NChangePartnerAddress } + nredirect { T _ T.NRedirect} + nokay { T _ T.NOkay} gunit { T _ T.GUnit } glabel { T _ T.GLabel } @@ -278,6 +281,9 @@ Messages : nintroduce '(' String ')' {Introduce $3} | nrequestsync '(' String ')' {RequestSync $3} | nchangepartneraddress '(' String ')' '(' String ')' '(' String ')' {ChangePartnerAddress $3 $6 $9} +Responses : nredirect '(' String ')' '(' String ')' {Redirect $3 $6} + | nokay {Okay} + PEnvEntry : penventry '(' String ')' '(' Values ')' {($3, $6)} diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index 8377f3a..5ff8db0 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -134,6 +134,8 @@ tokens :- "NSyncIncoming" { tok $ const NSyncIncoming } "NRequestSync" { tok $ const NRequestSync } "NChangePartnerAddress" { tok $ const NChangePartnerAddress } + "NRedirect" { tok $ const NRedirect } + "NOkay" { tok $ const NOkay } "Double:" $digit+ "." $digit+ { tok $ Double . read . (drop 7) } "Int:" $digit+ { tok $ Int . read . (drop 4)} @@ -254,6 +256,8 @@ data Token | NSyncIncoming | NRequestSync | NChangePartnerAddress + | NRedirect + | NOkay | String String | Int Int From f5824a27e3150a7950304ab3b04bfa10583e3768 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Fri, 16 Dec 2022 16:50:23 +0100 Subject: [PATCH 061/229] Solved a possible race condition (not the one in the example) --- dev-examples/handoff2/serverproblem | 0 src/Networking/Server.hs | 3 ++- 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 dev-examples/handoff2/serverproblem diff --git a/dev-examples/handoff2/serverproblem b/dev-examples/handoff2/serverproblem new file mode 100644 index 0000000..e69de29 diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index b5fb9ea..5110fff 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -118,12 +118,13 @@ sendRedirect handle ncmap userid = case Map.lookup userid ncmap of handleNewValue :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> Value -> IO () handleNewValue mvar userid val = do - networkconnectionmap <- MVar.readMVar mvar + networkconnectionmap <- MVar.takeMVar mvar case Map.lookup userid networkconnectionmap of Just networkconnection -> do ND.writeMessage (ncRead networkconnection) val Nothing -> do putStrLn "Error during recieving a networkmessage: Introduction is needed prior to sending values!" + MVar.putMVar mvar networkconnectionmap handleIntroduceClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Syntax.Type -> IO () handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype = do From 714449455ea918680bc0222b747c3d7ab5966381 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sat, 17 Dec 2022 19:42:12 +0100 Subject: [PATCH 062/229] Communication partners now wait for each other when stopping --- dev-examples/bidirectional/client.ldgvnw | 5 ++-- dev-examples/bidirectional/server.ldgvnw | 5 ++-- dev-examples/handoff2/client.ldgvnw | 2 ++ dev-examples/handoff2/handoff.ldgvnw | 2 ++ dev-examples/handoff2/server.ldgvnw | 2 ++ exe/Main.hs | 3 ++ src/Interpreter.hs | 10 +++++++ src/Networking/Client.hs | 35 ++++++++++++++++++++++-- src/Networking/Messages.hs | 3 ++ src/Networking/NetworkConnection.hs | 14 +++++++--- src/Networking/Serialize.hs | 3 ++ src/Networking/Server.hs | 14 +++++++++- src/Parsing/Grammar.y | 4 ++- src/Parsing/Tokens.x | 2 ++ src/PrettySyntax.hs | 1 + src/ProcessEnvironment.hs | 4 +-- src/Syntax.hs | 6 ++++ src/TCTyping.hs | 2 ++ src/ValueParsing/ValueGrammar.y | 6 ++++ src/ValueParsing/ValueTokens.x | 6 ++++ 20 files changed, 115 insertions(+), 14 deletions(-) diff --git a/dev-examples/bidirectional/client.ldgvnw b/dev-examples/bidirectional/client.ldgvnw index b7d7106..98c815d 100644 --- a/dev-examples/bidirectional/client.ldgvnw +++ b/dev-examples/bidirectional/client.ldgvnw @@ -7,7 +7,8 @@ val send2 (c: SendInt) = let x = ((send c) 1) in let = recv x in let y = ((send x2) 41) in - let = recv y in + let = recv y in + let y3 = end y2 in (m + n) val add2 (c1: dualof SendInt) = @@ -15,7 +16,7 @@ val add2 (c1: dualof SendInt) = let c22 = (send c2) 1300 in let = recv c22 in let c32 = (send c3) 37 in - + let c4 = end c32 in (m + n) val main : Int diff --git a/dev-examples/bidirectional/server.ldgvnw b/dev-examples/bidirectional/server.ldgvnw index 19a24a3..0c61456 100644 --- a/dev-examples/bidirectional/server.ldgvnw +++ b/dev-examples/bidirectional/server.ldgvnw @@ -7,7 +7,8 @@ val send2 (c: SendInt) = let x = ((send c) 1) in let = recv x in let y = ((send x2) 41) in - let = recv y in + let = recv y in + let y3 = end y2 in (m + n) val add2 (c1: dualof SendInt) = @@ -15,7 +16,7 @@ val add2 (c1: dualof SendInt) = let c22 = (send c2) 1300 in let = recv c22 in let c32 = (send c3) 37 in - + let c4 = end c32 in (m + n) val main : Int diff --git a/dev-examples/handoff2/client.ldgvnw b/dev-examples/handoff2/client.ldgvnw index 704098a..ea9d0c3 100644 --- a/dev-examples/handoff2/client.ldgvnw +++ b/dev-examples/handoff2/client.ldgvnw @@ -6,11 +6,13 @@ type SendInt : ! ~ssn = !Int. !Int. Unit val send2 (c: SendInt) = let x = ((send c) 1) in let y = ((send x) 42) in + let z = end y in () val add2 (c1: dualof SendInt) = let = recv c1 in let = recv c2 in + let c4 = end c3 in (m + n) val main : Unit diff --git a/dev-examples/handoff2/handoff.ldgvnw b/dev-examples/handoff2/handoff.ldgvnw index 2d3a7e8..d1fce48 100644 --- a/dev-examples/handoff2/handoff.ldgvnw +++ b/dev-examples/handoff2/handoff.ldgvnw @@ -12,5 +12,7 @@ val main = let con = (connect sock (dualof SendSendOneInt) "127.0.0.1" 4242) in let = recv con in let = recv oneint in + let c4 = end c2 in + let c5 = end c3 in result diff --git a/dev-examples/handoff2/server.ldgvnw b/dev-examples/handoff2/server.ldgvnw index ce86c45..9ab4cac 100644 --- a/dev-examples/handoff2/server.ldgvnw +++ b/dev-examples/handoff2/server.ldgvnw @@ -9,11 +9,13 @@ type SendSendOneInt : ! ~ssn = !SendOneInt. Unit val send2 (c: SendInt) = let x = ((send c) 1) in let y = ((send x) 42) in + let z = end y in () val add2 (c1: dualof SendInt) (c3: SendSendOneInt)= let = recv c1 in let y = ((send c3) c2) in + let z = end y in (m) -- Hier problematisch ldgv hat noch kein Konzept wie beim akzeptieren zwischen verschiedenen Types ungerschieden werden kann diff --git a/exe/Main.hs b/exe/Main.hs index acb3607..66859fe 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -10,6 +10,7 @@ module Main (main) where import Control.Applicative import Control.Monad import Control.Monad.Reader +import Control.Concurrent import Data.ByteString.Builder import Data.Foldable import Data.Maybe @@ -190,10 +191,12 @@ interpret Interpreter{ interpreterInputs = inputs, interpreterGradual = gradual Right a -> pure a Left err -> fail $ "Error: " ++ err liftIO $ I.interpret decls + -- For testing a small wait here, so all communications can come to a close liftIO $ putStrLn $ either (\v -> "Error: " ++ show v) (\v -> "Result: " ++ show v) (res :: Either SomeException P.Value) + -- liftIO $ threadDelay 1000000 compile :: CompileOpts -> Action () compile co = do diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 93f0084..54ce100 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -186,6 +186,16 @@ eval = \case -- Disable the old channel and get a new one newV <- liftIO $ disableOldVChan v return $ VPair val newV + End e -> do + liftIO $ putStrLn "Recieving value" + interpret' e >>= \v@(VChan ci) -> do + liftIO $ C.traceIO "Trying to close connection" + liftIO $ NClient.closeConnection ci + liftIO $ C.traceIO "Trying to close connection" + + -- Disable the channel + _ <- liftIO $ disableOldVChan v + return v Case e cases -> interpret' e >>= \(VLabel s) -> interpret' $ fromJust $ lookup s cases Create e -> do liftIO $ C.traceIO "Creating socket!" diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 632edda..ca1bbc8 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -15,15 +15,17 @@ import qualified Networking.UserID as UserID import qualified Data.Map as Map import GHC.IO.Handle import qualified Data.Maybe -import Networking.NetworkConnection (NetworkConnection(ncConnectionState), ConnectionState (Disconnected)) +import Networking.NetworkConnection (NetworkConnection(ncConnectionState, ncOwnUserID, ncRecievedRequestClose), ConnectionState (Disconnected)) import qualified Networking.Messages as Messages import qualified Control.Concurrent as MVar -import qualified Control.Concurrent as MVar import Control.Exception import GHC.Exception import qualified Syntax import qualified Networking.NetworkConnection as NCon import qualified Networking.Common as NC +import Networking.Messages (Messages(RequestClose)) +import qualified Control.Concurrent as MVar +import qualified Control.Concurrent as MVar sendMessage :: NetworkConnection Value -> Value -> IO () sendMessage networkconnection val = do @@ -174,6 +176,35 @@ sendVChanMessages newhost newport input = case input of sendVChanMessagesPEnv newhost newport xs +closeConnection :: NetworkConnection Value -> IO () +closeConnection networkconnection = do + connectionstate <- MVar.readMVar $ ncConnectionState networkconnection + case connectionstate of + NCon.Connected hostname port -> do + -- catch ( tryToSendNetworkMessage networkconnection hostname port (RequestClose $ Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) ) $ printConErr hostname port + waitForAck networkconnection hostname port + NCon.Disconnected -> putStrLn "Error when sending message: This channel is disconnected" + NCon.Emulated -> pure () + where + waitForAck con hostname port = do + connectionError <- MVar.newEmptyMVar + MVar.putMVar connectionError False + catch ( tryToSendNetworkMessage networkconnection hostname port (RequestClose $ Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) ) (\exception -> do + printConErr hostname port exception + _ <- MVar.takeMVar connectionError -- If we cannot communicate with them just close the connection + MVar.putMVar connectionError True + ) + errorOccured <- MVar.readMVar connectionError + if errorOccured then return () else do + shouldClose <- MVar.readMVar $ ncRecievedRequestClose con + if shouldClose then do + putStrLn "Closing handshake completed" + return () + else do + MVar.threadDelay 1000000 + waitForAck con hostname port + + {- makeVChanSendable :: String -> String -> Value -> IO Value diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs index 0444f6e..3a365d4 100644 --- a/src/Networking/Messages.hs +++ b/src/Networking/Messages.hs @@ -18,11 +18,13 @@ data Messages | SyncIncoming Partner [Value] | RequestSync Partner | ChangePartnerAddress Partner Hostname Port + | RequestClose Partner deriving Eq data Responses = Redirect Hostname Port | Okay + | OkayClose getPartnerID :: Messages -> String getPartnerID = \case @@ -33,6 +35,7 @@ getPartnerID = \case SyncIncoming p _ -> p RequestSync p -> p ChangePartnerAddress p _ _ -> p + RequestClose p -> p diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index ef9d2b3..25e0318 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -4,7 +4,7 @@ import Networking.DirectionalConnection import qualified Data.Maybe import qualified Control.Concurrent.MVar as MVar -data NetworkConnection a = NetworkConnection {ncRead :: DirectionalConnection a, ncWrite :: DirectionalConnection a, ncPartnerUserID :: Maybe String, ncOwnUserID :: Maybe String, ncConnectionState :: MVar.MVar ConnectionState} +data NetworkConnection a = NetworkConnection {ncRead :: DirectionalConnection a, ncWrite :: DirectionalConnection a, ncPartnerUserID :: Maybe String, ncOwnUserID :: Maybe String, ncConnectionState :: MVar.MVar ConnectionState, ncRecievedRequestClose :: MVar.MVar Bool} deriving Eq data ConnectionState = Connected {csHostname :: String, csPort :: String} @@ -20,7 +20,9 @@ newNetworkConnection partnerID ownID hostname port = do write <- newConnection connectionstate <- MVar.newEmptyMVar MVar.putMVar connectionstate $ Connected hostname port - return $ NetworkConnection read write (Just partnerID) (Just ownID) connectionstate + reqClose <- MVar.newEmptyMVar + MVar.putMVar reqClose False + return $ NetworkConnection read write (Just partnerID) (Just ownID) connectionstate reqClose createNetworkConnection :: [a] -> Int -> [a] -> Int -> Maybe String -> Maybe String -> String -> String -> IO (NetworkConnection a) @@ -29,7 +31,9 @@ createNetworkConnection readList readNew writeList writeNew partnerID ownID host write <- createConnection writeList writeNew connectionstate <- MVar.newEmptyMVar MVar.putMVar connectionstate $ Connected hostname port - return $ NetworkConnection read write partnerID ownID connectionstate + reqClose <- MVar.newEmptyMVar + MVar.putMVar reqClose False + return $ NetworkConnection read write partnerID ownID connectionstate reqClose createNetworkConnectionS :: ([a], Int) -> ([a], Int) -> String -> String -> (String, String) -> IO (NetworkConnection a) @@ -40,7 +44,9 @@ newEmulatedConnection :: DirectionalConnection a -> DirectionalConnection a -> I newEmulatedConnection r w = do connectionstate <- MVar.newEmptyMVar MVar.putMVar connectionstate Emulated - return $ NetworkConnection r w Nothing Nothing connectionstate + reqClose <- MVar.newEmptyMVar + MVar.putMVar reqClose True + return $ NetworkConnection r w Nothing Nothing connectionstate reqClose serializeNetworkConnection :: NetworkConnection a -> IO ([a], Int, [a], Int, String, String, String, String) serializeNetworkConnection nc = do diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index ddb2d40..5983e1f 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -42,6 +42,7 @@ instance Serializable Responses where serialize = \case Redirect host port -> serializeLabeledEntryMulti "NRedirect" host $ sLast port Okay -> return "NOkay" + OkayClose -> return "NOkayClose" instance Serializable Messages where serialize = \case @@ -52,6 +53,7 @@ instance Serializable Messages where SyncIncoming p vs -> serializeLabeledEntryMulti "NSyncIncoming" p $ sLast vs RequestSync p -> serializeLabeledEntry "NRequestSync" p ChangePartnerAddress p h port -> serializeLabeledEntryMulti "NChangePartnerAddress" p $ sNext h $ sLast port + RequestClose p -> serializeLabeledEntry "NRequestClose" p -- instance (Serializable a => Serializable (NCon.NetworkConnection a)) where instance Serializable (NCon.NetworkConnection Value) where @@ -187,6 +189,7 @@ instance Serializable Exp where Create e -> serializeLabeledEntry "ECreate" e Connect e0 t e1 e2 -> serializeLabeledEntryMulti "EConnect" e0 $ sNext t $ sNext e1 $ sLast e2 Accept e t -> serializeLabeledEntryMulti "EAccept" e $ sLast t + End e -> serializeLabeledEntry "EEnd" e instance Serializable (MathOp Exp) where serialize = \case diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 5110fff..d114ae2 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -26,7 +26,7 @@ import qualified Networking.Client as NClient import Networking.NetworkConnection import qualified Control.Concurrent as MVar -import Networking.NetworkConnection (newNetworkConnection, NetworkConnection (ncConnectionState, ncOwnUserID)) +import Networking.NetworkConnection (newNetworkConnection, NetworkConnection (ncConnectionState, ncOwnUserID, ncRecievedRequestClose)) import Networking.Messages (Messages(Introduce, RequestSync, SyncIncoming)) import qualified Control.Concurrent as MVar import qualified Control.Concurrent as MVar @@ -89,6 +89,8 @@ acceptClient mvar clientlist clientsocket = do handleRequestSync mvar userid SyncIncoming userid values -> do handleSyncIncoming mvar userid values + RequestClose userid -> do + handleRequestClose mvar userid _ -> do serial <- NSerialize.serialize deserialmessages putStrLn $ "Error unsupported networkmessage: "++ serial @@ -182,6 +184,16 @@ handleSyncIncoming mvar userid values = do ND.syncMessages (ncRead networkconnection) values Nothing -> return () +handleRequestClose :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> IO () +handleRequestClose mvar userid = do + networkconnectionmap <- MVar.takeMVar mvar + case Map.lookup userid networkconnectionmap of + Just networkconnection -> do + _ <- MVar.takeMVar $ ncRecievedRequestClose networkconnection + MVar.putMVar (ncRecievedRequestClose networkconnection) True + Nothing -> return () + MVar.putMVar mvar networkconnectionmap + hostaddressTypeToString :: HostAddress -> String hostaddressTypeToString hostaddress = do diff --git a/src/Parsing/Grammar.y b/src/Parsing/Grammar.y index 49af4f3..cd23aac 100644 --- a/src/Parsing/Grammar.y +++ b/src/Parsing/Grammar.y @@ -39,6 +39,7 @@ import qualified Parsing.Tokens as T create { T _ T.Create } connect { T _ T.Connect } accept { T _ T.Accept } + end { T _ T.End } -- for Binary Session Types; obsolete for Label Dependent ones select { T _ T.Select } @@ -94,7 +95,7 @@ import qualified Parsing.Tokens as T %nonassoc '>' '<' %left '+' '-' NEG POS %left '*' '/' -%left send recv connect create accept +%left send recv connect create accept end %nonassoc APP @@ -170,6 +171,7 @@ Exp : let var '=' Exp in Exp %prec LET { Let $2 $4 $6 } | send Exp %prec send { Send $2 } | recv Exp %prec recv { Recv $2 } | create Exp %prec create { Create $2 } + | end Exp %prec end { End $2 } -- | connect Exp Exp Exp Typ %prec connect { Connect $2 $3 $4 $5 } -- | connect Exp Typ Exp Exp %prec connect { Connect $2 $4 $5 $3} | connect Exp Typ Exp Exp %prec connect {Connect $2 $3 $4 $5} diff --git a/src/Parsing/Tokens.x b/src/Parsing/Tokens.x index e5361d3..0134601 100644 --- a/src/Parsing/Tokens.x +++ b/src/Parsing/Tokens.x @@ -45,6 +45,7 @@ tokens :- create { tok $ const Create } connect { tok $ const Connect } accept { tok $ const Accept } + end { tok $ const End } -- for Binary Session Types; obsolete for Label Dependent ones select { tok $ const Select } @@ -102,6 +103,7 @@ data Token = Create | Connect | Accept | + End | -- for Binary Session Types; obsolete for Label Dependent ones Select | diff --git a/src/PrettySyntax.hs b/src/PrettySyntax.hs index 8a1b851..12ff594 100644 --- a/src/PrettySyntax.hs +++ b/src/PrettySyntax.hs @@ -124,6 +124,7 @@ instance Pretty Exp where pretty (New t) = pretty "new" <+> pretty t pretty (Send e) = pretty "send" <+> pretty e pretty (Recv e) = pretty "recv" <+> pretty e + pretty (End e) = pretty "end" <+> pretty e pretty (Create i) = pretty "create" <+> pretty i pretty (Connect s t a i) = pretty "connect" <+> pretty s <+> pretty t <+> pretty a <+> pretty i pretty (Accept s t) = pretty "accept" <+> pretty s <+> pretty t diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index 1630757..4f0b71a 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -73,8 +73,8 @@ disableOldVChan value = case value of constate <- MVar.newEmptyMVar oldconstate <- MVar.takeMVar $ NCon.ncConnectionState nc MVar.putMVar constate oldconstate - MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected - let newNC = NCon.NetworkConnection (NCon.ncRead nc) (NCon.ncWrite nc) (NCOn.ncPartnerUserID nc) (NCon.ncOwnUserID nc) constate + MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected + let newNC = NCon.NetworkConnection (NCon.ncRead nc) (NCon.ncWrite nc) (NCOn.ncPartnerUserID nc) (NCon.ncOwnUserID nc) constate (NCon.ncRecievedRequestClose nc) return $ VChan newNC _ -> return value diff --git a/src/Syntax.hs b/src/Syntax.hs index 0a668f6..fd513ed 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -36,6 +36,7 @@ data Exp = Let Ident Exp Exp | Create Exp -- Create Port | Connect Exp Type Exp Exp -- Connect URL Port Type | Accept Exp Type -- Accept Socket Type + | End Exp -- End Connection deriving (Show,Eq) data MathOp e @@ -173,6 +174,7 @@ instance Freevars Exp where fv (Create e1) = fv e1 fv (Connect e0 ty e1 e2) = fv e0 <> fv ty <>fv e1 <> fv e2 fv (Accept e1 ty) = fv e1 <> fv ty + fv (End e1) = fv e1 fv (Case e cases) = foldl' (<>) (fv e) $ map (fv . snd) cases fv (Cast e t1 t2) = fv e fv (Succ e) = fv e @@ -203,6 +205,7 @@ instance Freevars Type where fv (TNatLeq _) = Set.empty fv (TNatRec e tz y ts) = fv e <> fv tz <> Set.delete y (fv ts) fv (TAbs x ty1 ty2) = fv ty1 <> Set.delete x (fv ty2) + fv TServerSocket = Set.empty instance Freevars TypeSegment where fv ts = fv (segTy ts) @@ -240,6 +243,7 @@ instance Substitution Exp where sb (Send e1) = Send (sb e1) sb (Recv e1) = Recv (sb e1) sb (Create e1) = Create (sb e1) + sb (End e1) = End (sb e1) sb (Connect e0 t e1 e2) = Connect (sb e0) t (sb e1) (sb e2) sb (Accept e1 t) = Accept (sb e1) t sb (Succ e1) = Succ (sb e1) @@ -352,6 +356,7 @@ single x tyx ty = TNatRec e (single x tyx tz) y (if x==y then ts else single x tyx ts) TAbs y t1 t2 -> TAbs y (single x tyx t1) (if x==y then t2 else single x tyx t2) + TServerSocket -> TServerSocket varsupply :: Ident -> [Ident] @@ -443,3 +448,4 @@ tsubst tn tyn ty = ts ty TSingle x -> ty TUnit -> TUnit TAbs _ _ _ -> ty + TServerSocket -> TServerSocket diff --git a/src/TCTyping.hs b/src/TCTyping.hs index 24cc3c1..b68ae7a 100644 --- a/src/TCTyping.hs +++ b/src/TCTyping.hs @@ -244,6 +244,8 @@ tySynth te e = return (TPair "" ty (dualof ty), te) -- I've got no real clue of what I am doing here hope it kind of works Create e1 -> do + return (TDyn, te) + End e1 -> do return (TServerSocket, te) Connect e0 ty e1 e2 -> do kiCheck (demoteTE te) ty Kssn diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 3a566db..4e45a10 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -86,6 +86,7 @@ import Networking.Messages erecv { T _ T.ERecv } ecase { T _ T.ECase } ecast { T _ T.ECast } + eend { T _ T.EEnd } madd { T _ T.MAdd } msub { T _ T.MSub } @@ -123,6 +124,8 @@ import Networking.Messages nchangepartneraddress {T _ T.NChangePartnerAddress } nredirect { T _ T.NRedirect} nokay { T _ T.NOkay} + nrequestclose { T _ T.NRequestClose } + nokayclose { T _ T.NOkayClose} gunit { T _ T.GUnit } glabel { T _ T.GLabel } @@ -255,6 +258,7 @@ Exp : elet '(' String ')' '(' Exp ')' '(' Exp ')' {Let $3 $6 $9} | erecv '(' Exp ')' {Recv $3} | ecase '(' Exp ')' '(' SStringExpArray ')' {Case $3 $6} | ecast '(' Exp ')' '(' Type ')' '(' Type ')' {Cast $3 $6 $9} + | eend '(' Exp ')' {End $3} MathOp : madd '(' Exp ')' '(' Exp ')' {Add $3 $6} @@ -280,9 +284,11 @@ Messages : nintroduce '(' String ')' {Introduce $3} | nsyncincoming '(' String ')''(' SValuesArray ')' {SyncIncoming $3 $6} | nrequestsync '(' String ')' {RequestSync $3} | nchangepartneraddress '(' String ')' '(' String ')' '(' String ')' {ChangePartnerAddress $3 $6 $9} + | nrequestclose '(' String ')' {RequestClose $3} Responses : nredirect '(' String ')' '(' String ')' {Redirect $3 $6} | nokay {Okay} + | nokayclose {OkayClose} PEnvEntry : penventry '(' String ')' '(' Values ')' {($3, $6)} diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index 5ff8db0..209b8f6 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -87,6 +87,7 @@ tokens :- "ERecv" { tok $ const ERecv } "ECase" { tok $ const ECase } "ECast" { tok $ const ECast } + "EEnd" { tok $ const EEnd } "MAdd" { tok $ const MAdd } "MSub" { tok $ const MSub } @@ -136,6 +137,8 @@ tokens :- "NChangePartnerAddress" { tok $ const NChangePartnerAddress } "NRedirect" { tok $ const NRedirect } "NOkay" { tok $ const NOkay } + "NRequestClose" { tok $ const NRequestClose } + "NOkayClose" { tok $ const NOkayClose } "Double:" $digit+ "." $digit+ { tok $ Double . read . (drop 7) } "Int:" $digit+ { tok $ Int . read . (drop 4)} @@ -206,6 +209,7 @@ data Token | ERecv | ECase | ECast + | EEnd | MAdd | MSub @@ -258,6 +262,8 @@ data Token | NChangePartnerAddress | NRedirect | NOkay + | NRequestClose + | NOkayClose | String String | Int Int From 9be84d13f65fa7c81dbdf540edeb4bcb9f3287ed Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sat, 17 Dec 2022 21:21:31 +0100 Subject: [PATCH 063/229] Added another example --- .../{simple => add}/client-old.ldgvnw | 0 dev-examples/add/client.ldgvnw | 20 +++++++ .../{simple => add}/server copy.ldgvnw | 0 dev-examples/add/server.ldgvnw | 20 +++++++ dev-examples/{simple => add}/test.ldgvnw | 0 dev-examples/simple/client.ldgvnw | 58 +++++++++++++----- dev-examples/simple/server.ldgvnw | 59 ++++++++++++++----- src/ValueParsing/ValueTokens.x | 6 +- 8 files changed, 132 insertions(+), 31 deletions(-) rename dev-examples/{simple => add}/client-old.ldgvnw (100%) create mode 100644 dev-examples/add/client.ldgvnw rename dev-examples/{simple => add}/server copy.ldgvnw (100%) create mode 100644 dev-examples/add/server.ldgvnw rename dev-examples/{simple => add}/test.ldgvnw (100%) diff --git a/dev-examples/simple/client-old.ldgvnw b/dev-examples/add/client-old.ldgvnw similarity index 100% rename from dev-examples/simple/client-old.ldgvnw rename to dev-examples/add/client-old.ldgvnw diff --git a/dev-examples/add/client.ldgvnw b/dev-examples/add/client.ldgvnw new file mode 100644 index 0000000..509798d --- /dev/null +++ b/dev-examples/add/client.ldgvnw @@ -0,0 +1,20 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let y = ((send x) 42) in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val main : Unit +val main = + let sock = (create 4343) in + let con = (connect sock SendInt "127.0.0.1" 4242 ) in -- This cannot be localhost, since this might break on containerized images + send2 con diff --git a/dev-examples/simple/server copy.ldgvnw b/dev-examples/add/server copy.ldgvnw similarity index 100% rename from dev-examples/simple/server copy.ldgvnw rename to dev-examples/add/server copy.ldgvnw diff --git a/dev-examples/add/server.ldgvnw b/dev-examples/add/server.ldgvnw new file mode 100644 index 0000000..e9f99db --- /dev/null +++ b/dev-examples/add/server.ldgvnw @@ -0,0 +1,20 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let y = ((send x) 42) in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val main : Int +val main = + let sock = (create 4242) in + let con = (accept sock (dualof SendInt)) in + add2 con diff --git a/dev-examples/simple/test.ldgvnw b/dev-examples/add/test.ldgvnw similarity index 100% rename from dev-examples/simple/test.ldgvnw rename to dev-examples/add/test.ldgvnw diff --git a/dev-examples/simple/client.ldgvnw b/dev-examples/simple/client.ldgvnw index 509798d..e7d6b0f 100644 --- a/dev-examples/simple/client.ldgvnw +++ b/dev-examples/simple/client.ldgvnw @@ -1,20 +1,50 @@ --- Simple example of Label-Dependent Session Types --- Interprets addition of two numbers +type End : ~unit = Unit -type SendInt : ! ~ssn = !Int. !Int. Unit -val send2 (c: SendInt) = - let x = ((send c) 1) in - let y = ((send x) 42) in - () +type EOS : ! ~un = {'EOS} +type End : ! ~unit = Unit -val add2 (c1: dualof SendInt) = - let = recv c1 in - let = recv c2 in - (m + n) +type TClient : ! ~ssn = + !( l : {'neg, 'add}) + case l of + { 'neg : !Int. ?Int. ?EOS. End + , 'add : !Int. !Int. ?Int. ?EOS. End + } -val main : Unit +type LClient : ! ~ssn = + !{'neg}. !Int. ?Int. ?EOS. End + +val lClient (d : TClient) (x : Int) : Int = + let d1 = (send d) 'neg in + let d2 = (send d1) x in + let = recv d2 in + let = recv d3 in + let zzz = end zz in + r + +type TServer : ! ~ssn = + ? ( x : { 'neg, 'add }) + case x of + { 'neg : ?Int. !Int. !EOS. End + , 'add : ?Int. ?Int. !Int. !EOS. End + } + +val lServer (c : TServer) : End = + let < l , c1 > = recv c in + let < x , c2 > = recv c1 in + case l of + { 'neg : + let c3 = send c2 (-x) in + send c3 'EOS + + , 'add : + let < y , c3 > = recv c2 in + let c4 = send c3 (x + y) in + send c4 'EOS + } + +val main : Int val main = let sock = (create 4343) in - let con = (connect sock SendInt "127.0.0.1" 4242 ) in -- This cannot be localhost, since this might break on containerized images - send2 con + let con = (connect sock TClient "127.0.0.1" 4242 ) in + ((lClient con) 42) diff --git a/dev-examples/simple/server.ldgvnw b/dev-examples/simple/server.ldgvnw index e9f99db..396b133 100644 --- a/dev-examples/simple/server.ldgvnw +++ b/dev-examples/simple/server.ldgvnw @@ -1,20 +1,51 @@ --- Simple example of Label-Dependent Session Types --- Interprets addition of two numbers +type End : ~unit = Unit -type SendInt : ! ~ssn = !Int. !Int. Unit -val send2 (c: SendInt) = - let x = ((send c) 1) in - let y = ((send x) 42) in - () +type EOS : ! ~un = {'EOS} +type End : ! ~unit = Unit + +type TClient : ! ~ssn = + !( l : {'neg, 'add}) + case l of + { 'neg : !Int. ?Int. ?EOS. End + , 'add : !Int. !Int. ?Int. ?EOS. End + } + +type LClient : ! ~ssn = + !{'neg}. !Int. ?Int. ?EOS. End -val add2 (c1: dualof SendInt) = - let = recv c1 in - let = recv c2 in - (m + n) +val lClient (d : TClient) (x : Int) : Int = + let d1 = (send d) 'neg in + let d2 = (send d1) x in + let = recv d2 in + let = recv d3 in + let zzz = end zz in + r -val main : Int +type TServer : ! ~ssn = + ? ( x : { 'neg, 'add }) + case x of + { 'neg : ?Int. !Int. !EOS. End + , 'add : ?Int. ?Int. !Int. !EOS. End + } + +val lServer (c : TServer) : End = + let < l , c1 > = recv c in + let < x , c2 > = recv c1 in + case l of + { 'neg : + let c3 = send c2 (-x) in + send c3 'EOS + , 'add : + let < y , c3 > = recv c2 in + let c4 = send c3 (x + y) in + send c4 'EOS + } + +val main : Unit val main = let sock = (create 4242) in - let con = (accept sock (dualof SendInt)) in - add2 con + let con = (accept sock (dualof TClient)) in + let e = lServer con in + let ee = end e in + () diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index 209b8f6..2a6491c 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -140,9 +140,9 @@ tokens :- "NRequestClose" { tok $ const NRequestClose } "NOkayClose" { tok $ const NOkayClose } - "Double:" $digit+ "." $digit+ { tok $ Double . read . (drop 7) } - "Int:" $digit+ { tok $ Int . read . (drop 4)} - "Integer:" $digit+ { tok $ Integer . read . (drop 8)} + Double\:[\-]?[0-9]+[\.][0-9]+ { tok $ Double . read . (drop 7) } + Int\:[\-]?[0-9]+ { tok $ Int . read . (drop 4)} + Integer\:[\-]?[0-9]+ { tok $ Integer . read . (drop 8)} String\:\"[^\"]*\" { tok $ String . (drop 7)} "Bool:False" { tok $ Bool . ignoreArgument False} "Bool:True" { tok $ Bool . ignoreArgument True} From 1151a1801ebeb72a16639ce7754e59dcafb4564b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sun, 18 Dec 2022 18:22:41 +0100 Subject: [PATCH 064/229] Redirect request now work --- dev-examples/handoff2/problem/client | 83 +++++++++++++ dev-examples/handoff2/problem/handoff | 61 ++++++++++ dev-examples/handoff2/problem/server | 120 +++++++++++++++++++ ldgv.cabal | 1 - src/Interpreter.hs | 30 +++-- src/Networking/Client.hs | 130 +++++--------------- src/Networking/Common.hs | 61 ++-------- src/Networking/NetworkConnection.hs | 2 +- src/Networking/Serialize.hs | 52 +------- src/Networking/Server.hs | 131 +++++++++++++------- src/ProcessEnvironment.hs | 42 ++++--- src/SerializeValues.hs | 166 -------------------------- 12 files changed, 428 insertions(+), 451 deletions(-) create mode 100644 dev-examples/handoff2/problem/client create mode 100644 dev-examples/handoff2/problem/handoff create mode 100644 dev-examples/handoff2/problem/server delete mode 100644 src/SerializeValues.hs diff --git a/dev-examples/handoff2/problem/client b/dev-examples/handoff2/problem/client new file mode 100644 index 0000000..343fa78 --- /dev/null +++ b/dev-examples/handoff2/problem/client @@ -0,0 +1,83 @@ +Invoking interpretation on 𝜆 (c : SendInt) let x = send c 1 in let y = send x 42 in let z = end y in () +Invoking interpretation on 𝜆 (c1 : ~SendInt) let = recv c1 in let = recv c2 in let c4 = end c3 in m + n +Invoking interpretation on let sock = create 4444 in let con = connect sock SendInt 127.0.0.1 4242 in send2 con +Invoking interpretation on create 4444 +Creating socket! +Invoking interpretation on 4444 +Leaving interpretation of 4444 with value VInt 4444 +Socket created +Invoking interpretation on let con = connect sock SendInt 127.0.0.1 4242 in send2 con +Invoking interpretation on connect sock SendInt 127.0.0.1 4242 +Client trying to connect +Invoking interpretation on sock +Leaving interpretation of create 4444 with value VServerSocket +Leaving interpretation of sock with value VServerSocket +Invoking interpretation on 127.0.0.1 +Leaving interpretation of 127.0.0.1 with value VString ""127.0.0.1"" +Invoking interpretation on 4242 +Leaving interpretation of 4242 with value VInt 4242 +Waiting for clients +Client connected: Introducing +Sending message:NIntroduceClient (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") (String:"4444") (TName (Bool:False) (String:"SendInt")) +Finished Handshake +Invoking interpretation on send2 con +Arguments for (send2) are (con) +Invoking interpretation on send2 +Invoking interpretation on con +Leaving interpretation of 𝜆 (c : SendInt) let x = send c 1 in let y = send x 42 in let z = end y in () with value VFunc "c" Let "x" (App (Send (Var "c")) (Lit (LNat 1))) (Let "y" (App (Send (Var "x")) (Lit (LNat 42))) (Let "z" (End (Var "y")) (Lit LUnit))) +Leaving interpretation of send2 with value VFunc "c" Let "x" (App (Send (Var "c")) (Lit (LNat 1))) (Let "y" (App (Send (Var "x")) (Lit (LNat 42))) (Let "z" (End (Var "y")) (Lit LUnit))) +Invoking interpretation on let x = send c 1 in let y = send x 42 in let z = end y in () +Invoking interpretation on send c 1 +Arguments for (send c) are (1) +Invoking interpretation on send c +Invoking interpretation on c +Invoking interpretation on 1 +Leaving interpretation of connect sock SendInt 127.0.0.1 4242 with value VChan +Leaving interpretation of con with value VChan +Leaving interpretation of c with value VChan +Leaving interpretation of send c with value VSend (VChan) +Trying to connect to: 127.0.0.1:4242 +Leaving interpretation of 1 with value VInt 1 +Sending message:NNewValue (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") (VInt (Int:1)) +Waiting for response +Message okay +Invoking interpretation on let y = send x 42 in let z = end y in () +Invoking interpretation on send x 42 +Arguments for (send x) are (42) +Invoking interpretation on send x +Invoking interpretation on x +Invoking interpretation on 42 +Leaving interpretation of send c 1 with value VChan +Leaving interpretation of x with value VChan +Leaving interpretation of send x with value VSend (VChan) +Trying to connect to: 127.0.0.1:4242 +Leaving interpretation of 42 with value VInt 42 +Sending message:NNewValue (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") (VInt (Int:42)) +Waiting for response +Accepted new client +Waiting for clients +Recieved message:NChangePartnerAddress (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") (String:"127.0.0.1") (String:"4343") +Trying to connect to: 127.0.0.1:4343 +Sending message:NRequestSync (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") +Waiting for response +Message okay +Invoking interpretation on let z = end y in () +Invoking interpretation on end y +Invoking interpretation on y +Leaving interpretation of send x 42 with value VChan +Leaving interpretation of y with value VChan +Trying to connect to: 127.0.0.1:4242 +Sending message:NRequestClose (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") +Waiting for response +Message okay +Message okay +Trying to connect to: 127.0.0.1:4343 +Sending message:NSyncIncoming (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") (SValuesArray [VInt (Int:1), VInt (Int:42)]) +Waiting for response +Message okay +Sending message:NOkay +Trying to connect to: 127.0.0.1:4242 +Sending message:NRequestClose (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") +Waiting for response +Message okay +^C diff --git a/dev-examples/handoff2/problem/handoff b/dev-examples/handoff2/problem/handoff new file mode 100644 index 0000000..7af6bb3 --- /dev/null +++ b/dev-examples/handoff2/problem/handoff @@ -0,0 +1,61 @@ +Leaving tySynth with let = recv con in let = recv oneint in let c4 = end c2 in let c5 = end c3 in result : Int -| [(con, (0, ~SendSendOneInt)), (sock, (_, ★)), (main, (_, Int))] +Leaving tySynth with let con = connect sock ~SendSendOneInt 127.0.0.1 4242 in let = recv con in let = recv oneint in let c4 = end c2 in let c5 = end c3 in result : Int -| [(sock, (_, ★)), (main, (_, Int))] +Leaving tySynth with let sock = create 4343 in let con = connect sock ~SendSendOneInt 127.0.0.1 4242 in let = recv con in let = recv oneint in let c4 = end c2 in let c5 = end c3 in result : Int -| [(main, (_, Int))] +subtype: Entering [(main, (_, Int))] (Int) (Int) +Success: ([(main, (_, Int))], []) +Invoking interpretation on let sock = create 4343 in let con = connect sock ~SendSendOneInt 127.0.0.1 4242 in let = recv con in let = recv oneint in let c4 = end c2 in let c5 = end c3 in result +Invoking interpretation on create 4343 +Creating socket! +Invoking interpretation on 4343 +Leaving interpretation of 4343 with value VInt 4343 +Socket created +Waiting for clients +Invoking interpretation on let con = connect sock ~SendSendOneInt 127.0.0.1 4242 in let = recv con in let = recv oneint in let c4 = end c2 in let c5 = end c3 in result +Invoking interpretation on connect sock ~SendSendOneInt 127.0.0.1 4242 +Client trying to connect +Invoking interpretation on sock +Leaving interpretation of create 4343 with value VServerSocket +Leaving interpretation of sock with value VServerSocket +Invoking interpretation on 127.0.0.1 +Leaving interpretation of 127.0.0.1 with value VString ""127.0.0.1"" +Invoking interpretation on 4242 +Leaving interpretation of 4242 with value VInt 4242 +Client connected: Introducing +Sending message:NIntroduceClient (String:"jA4YaqSHz3CbIwZiw5UWFxeNYM4ibINapqukOxjg9bV07B94E3q19QDgwgThmxK7cJy7rQCmR9viuYmcYm5NPEWrJInZPqV2y5nTOInyORhyqjcatRD8C8JASy5xu93c") (String:"4343") (TName (Bool:True) (String:"SendSendOneInt")) +Finished Handshake +Invoking interpretation on let = recv con in let = recv oneint in let c4 = end c2 in let c5 = end c3 in result +Invoking interpretation on recv con +Invoking interpretation on con +Leaving interpretation of connect sock ~SendSendOneInt 127.0.0.1 4242 with value VChan +Leaving interpretation of con with value VChan +Accepted new client +Waiting for clients +Accepted new client +Waiting for clients +Recieved message:NRequestSync (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") +Sending message:NOkay +Recieved message:NNewValue (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") (((String:"127.0.0.1") (String:"4444")))) +Sending message:NOkay +Read VChan from Chan, over expression Var "con" +Leaving interpretation of recv con with value VPair +Invoking interpretation on let = recv oneint in let c4 = end c2 in let c5 = end c3 in result +Invoking interpretation on recv oneint +Invoking interpretation on oneint +Leaving interpretation of oneint with value VChan +Accepted new client +Waiting for clients +Recieved message:NSyncIncoming (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") (SValuesArray [VInt (Int:1), VInt (Int:42)]) +Sending message:NOkay +Accepted new client +Waiting for clients +Recieved message:NRequestClose (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") +Sending message:NOkay +Accepted new client +Waiting for clients +Recieved message:NRequestClose (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") +Sending message:NOkay +Accepted new client +Waiting for clients +Recieved message:NRequestClose (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") +Sending message:NOkay +^C diff --git a/dev-examples/handoff2/problem/server b/dev-examples/handoff2/problem/server new file mode 100644 index 0000000..9d304f1 --- /dev/null +++ b/dev-examples/handoff2/problem/server @@ -0,0 +1,120 @@ +Invoking interpretation on 𝜆 (c : SendInt) let x = send c 1 in let y = send x 42 in let z = end y in () +Invoking interpretation on 𝜆 (c1 : ~SendInt) 𝜆 (c3 : SendSendOneInt) let = recv c1 in let y = send c3 c2 in let z = end y in m +Invoking interpretation on let sock = create 4242 in let con1 = accept sock ~SendInt in let con2 = accept sock SendSendOneInt in add2 con1 con2 +Invoking interpretation on create 4242 +Creating socket! +Invoking interpretation on 4242 +Leaving interpretation of 4242 with value VInt 4242 +Socket created +Waiting for clients +Invoking interpretation on let con1 = accept sock ~SendInt in let con2 = accept sock SendSendOneInt in add2 con1 con2 +Invoking interpretation on accept sock ~SendInt +Accepting new client! +Invoking interpretation on sock +Leaving interpretation of create 4242 with value VServerSocket +Leaving interpretation of sock with value VServerSocket +Searching for correct communicationpartner +Accepted new client +Waiting for clients +Recieved message:NIntroduceClient (String:"jA4YaqSHz3CbIwZiw5UWFxeNYM4ibINapqukOxjg9bV07B94E3q19QDgwgThmxK7cJy7rQCmR9viuYmcYm5NPEWrJInZPqV2y5nTOInyORhyqjcatRD8C8JASy5xu93c") (String:"4343") (TName (Bool:True) (String:"SendSendOneInt")) +Sending message:NIntroduce (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") +Sending message:NOkay +Accepted new client +Waiting for clients +Recieved message:NIntroduceClient (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") (String:"4444") (TName (Bool:False) (String:"SendInt")) +Sending message:NIntroduce (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") +Sending message:NOkay +Client accepted +Client successfully accepted! +Invoking interpretation on let con2 = accept sock SendSendOneInt in add2 con1 con2 +Invoking interpretation on accept sock SendSendOneInt +Accepting new client! +Invoking interpretation on sock +Leaving interpretation of sock with value VServerSocket +Searching for correct communicationpartner +Client accepted +Client successfully accepted! +Invoking interpretation on add2 con1 con2 +Arguments for (add2 con1) are (con2) +Invoking interpretation on add2 con1 +Arguments for (add2) are (con1) +Invoking interpretation on add2 +Invoking interpretation on con1 +Leaving interpretation of 𝜆 (c1 : ~SendInt) 𝜆 (c3 : SendSendOneInt) let = recv c1 in let y = send c3 c2 in let z = end y in m with value VFunc "c1" Lam MMany "c3" (TName False "SendSendOneInt") (LetPair "m" "c2" (Recv (Var "c1")) (Let "y" (App (Send (Var "c3")) (Var "c2")) (Let "z" (End (Var "y")) (Var "m")))) +Leaving interpretation of add2 with value VFunc "c1" Lam MMany "c3" (TName False "SendSendOneInt") (LetPair "m" "c2" (Recv (Var "c1")) (Let "y" (App (Send (Var "c3")) (Var "c2")) (Let "z" (End (Var "y")) (Var "m")))) +Invoking interpretation on 𝜆 (c3 : SendSendOneInt) let = recv c1 in let y = send c3 c2 in let z = end y in m +Invoking interpretation on con2 +Leaving interpretation of 𝜆 (c3 : SendSendOneInt) let = recv c1 in let y = send c3 c2 in let z = end y in m with value VFunc "c3" LetPair "m" "c2" (Recv (Var "c1")) (Let "y" (App (Send (Var "c3")) (Var "c2")) (Let "z" (End (Var "y")) (Var "m"))) +Leaving interpretation of add2 con1 with value VFunc "c3" LetPair "m" "c2" (Recv (Var "c1")) (Let "y" (App (Send (Var "c3")) (Var "c2")) (Let "z" (End (Var "y")) (Var "m"))) +Invoking interpretation on let = recv c1 in let y = send c3 c2 in let z = end y in m +Invoking interpretation on recv c1 +Invoking interpretation on c1 +Accepted new client +Waiting for clients +Leaving interpretation of accept sock ~SendInt with value VChan +Leaving interpretation of con1 with value VChan +Leaving interpretation of c1 with value VChan +Recieved message:NNewValue (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") (VInt (Int:1)) +Sending message:NOkay +Accepted new client +Waiting for clients +Read VInt 1 from Chan, over expression Var "c1" +Leaving interpretation of recv c1 with value VPair +Invoking interpretation on let y = send c3 c2 in let z = end y in m +Invoking interpretation on send c3 c2 +Arguments for (send c3) are (c2) +Invoking interpretation on send c3 +Invoking interpretation on c3 +Invoking interpretation on c2 +Leaving interpretation of accept sock SendSendOneInt with value VChan +Leaving interpretation of con2 with value VChan +Leaving interpretation of c3 with value VChan +Leaving interpretation of send c3 with value VSend (VChan) +Trying to connect to: 127.0.0.1:4343 +Leaving interpretation of c2 with value VChan +Sending message:NNewValue (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") (((String:"127.0.0.1") (String:"4444")))) +Trying to connect to: 127.0.0.1:4444 +Sending message:NChangePartnerAddress (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") (String:"127.0.0.1") (String:"4343") +Waiting for response +Recieved message:NNewValue (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") (VInt (Int:42)) +Sending message:NOkay +Accepted new client +Waiting for clients +Recieved message:NRequestClose (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") +Sending message:NOkay +Message okay +Waiting for response +Message okay +Invoking interpretation on let z = end y in m +Invoking interpretation on end y +Invoking interpretation on y +Leaving interpretation of send c3 c2 with value VChan +Leaving interpretation of y with value VChan +Trying to connect to: 127.0.0.1:4343 +Sending message:NRequestClose (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") +Waiting for response +Message okay +Accepted new client +Waiting for clients +Recieved message:NRequestClose (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") +Sending message:NOkay +Trying to connect to: 127.0.0.1:4343 +Sending message:NRequestClose (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") +Waiting for response +Message okay +Trying to connect to: 127.0.0.1:4343 +Sending message:NRequestClose (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") +Waiting for response +Message okay +Trying to connect to: 127.0.0.1:4343 +Communication Partner 127.0.0.1:4343not found! +Invoking interpretation on m +Leaving interpretation of m with value VInt 1 +Leaving interpretation of let z = end y in m with value VInt 1 +Leaving interpretation of let y = send c3 c2 in let z = end y in m with value VInt 1 +Leaving interpretation of let = recv c1 in let y = send c3 c2 in let z = end y in m with value VInt 1 +Leaving interpretation of add2 con1 con2 with value VInt 1 +Leaving interpretation of let con2 = accept sock SendSendOneInt in add2 con1 con2 with value VInt 1 +Leaving interpretation of let con1 = accept sock ~SendInt in let con2 = accept sock SendSendOneInt in add2 con1 con2 with value VInt 1 +Leaving interpretation of let sock = create 4242 in let con1 = accept sock ~SendInt in let con2 = accept sock SendSendOneInt in add2 con1 con2 with value VInt 1 +Result: VInt 1 diff --git a/ldgv.cabal b/ldgv.cabal index 8020c32..117f3f7 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -77,7 +77,6 @@ library Parsing.Grammar Parsing.Tokens ProcessEnvironment - SerializeValues Syntax Typechecker ValueParsing.ValueGrammar diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 54ce100..5e6a4e3 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -17,7 +17,7 @@ import Network.Socket -- import qualified Network.Socket as NSocket import Control.Concurrent (forkIO) import Data.Foldable (find) -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, fromMaybe) import qualified Data.Map as Map import ProcessEnvironment import qualified Control.Monad as M @@ -25,7 +25,6 @@ import Control.Monad.Reader as R import Control.Applicative ((<|>)) import Control.Exception import Kinds (Multiplicity(..)) -import qualified SerializeValues as SV import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG @@ -47,6 +46,9 @@ import qualified Networking.NetworkConnection as NCon -- import ProcessEnvironment import qualified Control.Concurrent as MVar import ProcessEnvironment (disableOldVChan) +import Networking.NetworkConnection (NetworkConnection(ncPartnerUserID)) +import qualified Control.Concurrent as MVar +import qualified Control.Concurrent as MVar -- import qualified Networking.NetworkConnection as NCon -- import qualified Networking.NetworkConnection as NCon @@ -170,28 +172,25 @@ eval = \case w <- liftIO DC.newConnection nc1 <- liftIO $ NCon.newEmulatedConnection r w nc2 <- liftIO $ NCon.newEmulatedConnection w r - return $ VPair (VChan nc1) $ VChan nc2 + mvar <- liftIO MVar.newEmptyMVar + liftIO $ MVar.putMVar mvar Map.empty + return $ VPair (VChan nc1 mvar) $ VChan nc2 mvar Send e -> VSend <$> interpret' e -- Apply VSend to the output of interpret' e Recv e -> do - liftIO $ putStrLn "Recieving value" - interpret' e >>= \v@(VChan ci) -> do + interpret' e >>= \v@(VChan ci mvar) -> do let dcRead = NCon.ncRead ci - liftIO $ putStrLn "Trying to read new value" valunclean <- liftIO $ DC.readUnreadMessage dcRead - liftIO $ putStrLn "Read new value" - val <- liftIO $ NC.replaceVChanSerial valunclean - liftIO $ putStrLn "Replaced Serial" + val <- liftIO $ NS.replaceVChanSerial mvar valunclean liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e -- Disable the old channel and get a new one newV <- liftIO $ disableOldVChan v return $ VPair val newV End e -> do - liftIO $ putStrLn "Recieving value" - interpret' e >>= \v@(VChan ci) -> do - liftIO $ C.traceIO "Trying to close connection" + liftIO $ C.traceIO "Trying to close a connection" + interpret' e >>= \v@(VChan ci mvar) -> do + liftIO $ C.traceIO $ "Trying to close connection with:" ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID ci) liftIO $ NClient.closeConnection ci - liftIO $ C.traceIO "Trying to close connection" -- Disable the channel _ <- liftIO $ disableOldVChan v @@ -223,7 +222,7 @@ eval = \case Nothing -> throw $ CommunicationPartnerNotFoundException newuser Just networkconnection -> do liftIO $ C.traceIO "Client successfully accepted!" - return $ VChan networkconnection + return $ VChan networkconnection mvar _ -> throw $ NotAnExpectedValueException "VServerSocket" val Connect e0 t e1 e2-> do @@ -280,8 +279,7 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) let env' = extendEnv n1 (VInt (n-1)) (extendEnv f natrec env) R.local (const env') (interpret' es) -- interpretApp _ (VSend v@(VChan _ c handle _ _ _)) w = do -interpretApp _ (VSend v@(VChan cc)) w = do - liftIO $ putStrLn $ "Trying to send message:" ++ show w +interpretApp _ (VSend v@(VChan cc _)) w = do liftIO $ NClient.sendMessage cc w -- Disable old VChan diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index ca1bbc8..d952887 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -1,7 +1,7 @@ module Networking.Client where +import qualified Config import Networking.NetworkConnection as NCon -import qualified Networking.Common as NC import ProcessEnvironment import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG @@ -16,26 +16,22 @@ import qualified Data.Map as Map import GHC.IO.Handle import qualified Data.Maybe import Networking.NetworkConnection (NetworkConnection(ncConnectionState, ncOwnUserID, ncRecievedRequestClose), ConnectionState (Disconnected)) -import qualified Networking.Messages as Messages -import qualified Control.Concurrent as MVar +import Control.Concurrent import Control.Exception import GHC.Exception import qualified Syntax -import qualified Networking.NetworkConnection as NCon import qualified Networking.Common as NC import Networking.Messages (Messages(RequestClose)) -import qualified Control.Concurrent as MVar -import qualified Control.Concurrent as MVar sendMessage :: NetworkConnection Value -> Value -> IO () sendMessage networkconnection val = do - connectionstate <- MVar.takeMVar $ ncConnectionState networkconnection + connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port -> do catch (tryToSend networkconnection hostname port val) $ printConErr hostname port - NCon.Disconnected -> putStrLn "Error when sending message: This channel is disconnected" + NCon.Disconnected -> Config.traceIO "Error when sending message: This channel is disconnected" NCon.Emulated -> DC.writeMessage (ncWrite networkconnection) val - MVar.putMVar (ncConnectionState networkconnection) connectionstate + -- MVar.putMVar (ncConnectionState networkconnection) connectionstate tryToSend :: NetworkConnection Value -> String -> String -> Value -> IO () @@ -44,47 +40,39 @@ tryToSend networkconnection hostname port val = do addrFlags = [] , addrSocketType = Stream } - putStrLn $ "Trying to connect to: " ++ hostname ++":"++port + Config.traceIO $ "Trying to connect to: " ++ hostname ++":"++port addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port - --addrInfo <- getAddrInfo (Just hints) (Just "127.0.0.1") $ Just port -- Thia is obviously only for testing clientsocket <- NC.openSocketNC $ head addrInfo - -- putStrLn "Before connect" connect clientsocket $ addrAddress $ head addrInfo - -- putStrLn "After connect" handle <- NC.getHandle clientsocket - putStrLn "Client connected: Sending Message" - -- valcleaned <- makeVChanSendable hostname port val -- This sends a ChangeNetworkPartner Message if appropriate valcleaned <- NC.replaceVChan val NC.sendMessage (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) valcleaned) handle DC.writeMessage (ncWrite networkconnection) valcleaned - -- putStrLn "Sending message to old communication partner" sendVChanMessages hostname port val -- This sends a ChangeNetworkPartner Message if appropriate - -- putStrLn "Disabling Chans" disableVChans val -- Disables all sent VChans for the sending party - -- putStrLn "Chans disabled" - putStrLn "Waiting for response" + Config.traceIO "Waiting for response" mbyresponse <- NC.recieveResponse handle hClose handle case mbyresponse of Just response -> case response of - Okay -> putStrLn "Message okay" + Okay -> Config.traceIO "Message okay" Redirect host port -> do - putStrLn "Communication partner changed address, resending" + Config.traceIO "Communication partner changed address, resending" tryToSend networkconnection host port val - Nothing -> putStrLn "Error when recieving response" + Nothing -> Config.traceIO "Error when recieving response" sendNetworkMessage :: NetworkConnection Value -> Messages -> IO () sendNetworkMessage networkconnection message = do - connectionstate <- MVar.takeMVar $ ncConnectionState networkconnection + connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port -> do catch ( tryToSendNetworkMessage networkconnection hostname port message ) $ printConErr hostname port - NCon.Disconnected -> putStrLn "Error when sending message: This channel is disconnected" + NCon.Disconnected -> Config.traceIO "Error when sending message: This channel is disconnected" NCon.Emulated -> pure () - MVar.putMVar (ncConnectionState networkconnection) connectionstate + --MVar.putMVar (ncConnectionState networkconnection) connectionstate tryToSendNetworkMessage :: NetworkConnection Value -> String -> String -> Messages -> IO () tryToSendNetworkMessage networkconnection hostname port message = do @@ -92,30 +80,26 @@ tryToSendNetworkMessage networkconnection hostname port message = do addrFlags = [] , addrSocketType = Stream } - putStrLn $ "Trying to connect to: " ++ hostname ++":"++port + Config.traceIO $ "Trying to connect to: " ++ hostname ++":"++port addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port - --addrInfo <- getAddrInfo (Just hints) (Just "127.0.0.1") $ Just port -- Thia is obviously only for testing clientsocket <- NC.openSocketNC $ head addrInfo - putStrLn "Before connect" connect clientsocket $ addrAddress $ head addrInfo - putStrLn "After connect" handle <- NC.getHandle clientsocket - putStrLn "Client connected: Sending NetworkMessage" NC.sendMessage message handle - putStrLn "Waiting for response" + Config.traceIO "Waiting for response" mbyresponse <- NC.recieveResponse handle hClose handle case mbyresponse of Just response -> case response of - Okay -> putStrLn "Message okay" + Okay -> Config.traceIO "Message okay" Redirect host port -> do - putStrLn "Communication partner changed address, resending" + Config.traceIO "Communication partner changed address, resending" tryToSendNetworkMessage networkconnection host port message - Nothing -> putStrLn "Error when recieving response" + Nothing -> Config.traceIO "Error when recieving response" printConErr :: String -> String -> IOException -> IO () -printConErr hostname port err = putStrLn $ "Communication Partner " ++ hostname ++ ":" ++ port ++ "not found!" +printConErr hostname port err = Config.traceIO $ "Communication Partner " ++ hostname ++ ":" ++ port ++ "not found!" initialConnect :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> Syntax.Type -> IO Value @@ -129,19 +113,17 @@ initialConnect mvar hostname port ownport syntype= do connect clientsocket $ addrAddress $ head addrInfo handle <- NC.getHandle clientsocket ownuserid <- UserID.newRandomUserID - putStrLn "Client connected: Introducing" + Config.traceIO "Client connected: Introducing" NC.sendMessage (Messages.IntroduceClient ownuserid ownport syntype) handle introductionanswer <- NC.waitForServerIntroduction handle - putStrLn "Finished Handshake" + Config.traceIO "Finished Handshake" hClose handle newConnection <- newNetworkConnection introductionanswer ownuserid hostname port networkconnectionmap <- MVar.takeMVar mvar let newNetworkconnectionmap = Map.insert introductionanswer newConnection networkconnectionmap MVar.putMVar mvar newNetworkconnectionmap - return $ VChan newConnection - --- openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + return $ VChan newConnection mvar sendVChanMessages :: String -> String -> Value -> IO () sendVChanMessages newhost newport input = case input of @@ -154,19 +136,11 @@ sendVChanMessages newhost newport input = case input of VFuncCast v a b -> sendVChanMessages newhost newport v VRec penv a b c d -> sendVChanMessagesPEnv newhost newport penv VNewNatRec penv a b c d e f g -> sendVChanMessagesPEnv newhost newport penv - VChan nc -> do - putStrLn "Attempting to sending ChangePartnerAddress" - -- connectionstate <- MVar.readMVar $ ncConnectionState nc - -- putStrLn "Aquired connectionstate" + VChan nc _-> do sendNetworkMessage nc (Messages.ChangePartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID nc) newhost newport) - -- MVar.putMVar (ncConnectionState nc) Disconnected - -- _ <- MVar.takeMVar $ ncConnectionState nc - -- MVar.putMVar (ncConnectionState nc) Disconnected - putStrLn "Sent ChangePartnerAddress" _ <- MVar.takeMVar $ ncConnectionState nc - putStrLn "Got connectionstate - Changeing to redirect" + putStrLn $ "Set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest newhost newport - putStrLn "Set RedirectRequest" _ -> return () where sendVChanMessagesPEnv :: String -> String -> [(String, Value)] -> IO () @@ -181,9 +155,8 @@ closeConnection networkconnection = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port -> do - -- catch ( tryToSendNetworkMessage networkconnection hostname port (RequestClose $ Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) ) $ printConErr hostname port waitForAck networkconnection hostname port - NCon.Disconnected -> putStrLn "Error when sending message: This channel is disconnected" + NCon.Disconnected -> Config.traceIO "Error when sending message: This channel is disconnected" NCon.Emulated -> pure () where waitForAck con hostname port = do @@ -198,55 +171,8 @@ closeConnection networkconnection = do if errorOccured then return () else do shouldClose <- MVar.readMVar $ ncRecievedRequestClose con if shouldClose then do - putStrLn "Closing handshake completed" + Config.traceIO "Closing handshake completed" return () else do - MVar.threadDelay 1000000 - waitForAck con hostname port - - - -{- -makeVChanSendable :: String -> String -> Value -> IO Value -makeVChanSendable newhost newport input = case input of - VSend v -> do - nv <- makeVChanSendable newhost newport v - return $ VSend nv - VPair v1 v2 -> do - nv1 <- makeVChanSendable newhost newport v1 - nv2 <- makeVChanSendable newhost newport v2 - return $ VPair nv1 nv2 - VFunc penv a b -> do - newpenv <- makeVChanSendablePEnv newhost newport penv - return $ VFunc newpenv a b - VDynCast v g -> do - nv <- makeVChanSendable newhost newport v - return $ VDynCast nv g - VFuncCast v a b -> do - nv <- makeVChanSendable newhost newport v - return $ VFuncCast nv a b - VRec penv a b c d -> do - newpenv <- makeVChanSendablePEnv newhost newport penv - return $ VRec newpenv a b c d - VNewNatRec penv a b c d e f g -> do - newpenv <- makeVChanSendablePEnv newhost newport penv - return $ VNewNatRec newpenv a b c d e f g - VChan nc -> do - putStrLn "Attempting to sending ChangePartnerAddress" - -- connectionstate <- MVar.readMVar $ ncConnectionState nc - -- putStrLn "Aquired connectionstate" - sendNetworkMessage nc (Messages.ChangePartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID nc) newhost newport) - -- MVar.putMVar (ncConnectionState nc) Disconnected - -- _ <- MVar.takeMVar $ ncConnectionState nc - -- MVar.putMVar (ncConnectionState nc) Disconnected - putStrLn "Sent ChangePartnerAddress" - return $ VChan nc - _ -> return input - where - makeVChanSendablePEnv :: String -> String -> [(String, Value)] -> IO [(String, Value)] - makeVChanSendablePEnv _ _ [] = return [] - makeVChanSendablePEnv newhost newport (x:xs) = do - newval <- makeVChanSendable newhost newport $ snd x - rest <- makeVChanSendablePEnv newhost newport xs - return $ (fst x, newval):rest --} \ No newline at end of file + threadDelay 1000000 + waitForAck con hostname port \ No newline at end of file diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index b295200..6492dba 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -25,7 +25,8 @@ import qualified ValueParsing.ValueGrammar as VG import qualified Networking.DirectionalConnection as DC import Networking.DirectionalConnection (DirectionalConnection) import Networking.Serialize (Serializable (serialize)) -import Networking.NetworkConnection (createNetworkConnection, createNetworkConnectionS, serializeNetworkConnection) +import Networking.NetworkConnection +import qualified Config newtype ServerException = NoIntroductionException String deriving Eq @@ -39,7 +40,7 @@ instance Exception ServerException sendMessage :: NSerialize.Serializable a => a -> Handle -> IO () sendMessage value handle = do serializedValue <- NSerialize.serialize value - putStrLn $ "Sending message:" ++ serializedValue + Config.traceIO $ "Sending message:" ++ serializedValue hPutStrLn handle (serializedValue ++" ") recieveMessage :: Handle -> IO (Maybe Messages) @@ -48,7 +49,7 @@ recieveMessage handle = do case VT.runAlex message VG.parseMessages of -- case VT.runAlex message VG.parseValues of Left err -> do - putStrLn $ "Error during recieving a networkmessage: "++err + Config.traceIO $ "Error during recieving a networkmessage: "++err return Nothing Right deserialmessage -> return $ Just deserialmessage @@ -57,7 +58,7 @@ recieveResponse handle = do message <- hGetLine handle case VT.runAlex message VG.parseResponses of Left err -> do - putStrLn $ "Error during recieving a networkmessage: "++err + Config.traceIO $ "Error during recieving a networkmessage: "++err return Nothing Right deserialmessage -> return $ Just deserialmessage @@ -69,65 +70,20 @@ getHandle socket = do hSetBuffering hdl NoBuffering return hdl - -getSocket :: MVar.MVar Socket -> Socket -> IO () -getSocket mvar socket = do - putStrLn "Trying to send socket" - MVar.putMVar mvar socket - putStrLn "Sent socket" - waitForServerIntroduction :: Handle -> IO String waitForServerIntroduction handle = do message <- hGetLine handle case VT.runAlex message VG.parseMessages of Left err -> do - putStrLn $ "Error during server introduction: "++err + Config.traceIO $ "Error during server introduction: "++err throw $ NoIntroductionException message Right deserial -> case deserial of Introduce partner -> do return partner _ -> do - putStrLn $ "Error during server introduction, wrong message: "++ message + Config.traceIO $ "Error during server introduction, wrong message: "++ message throw $ NoIntroductionException message - -replaceVChanSerial :: Value -> IO Value -replaceVChanSerial input = case input of - VSend v -> do - nv <- replaceVChanSerial v - return $ VSend nv - VPair v1 v2 -> do - nv1 <- replaceVChanSerial v1 - nv2 <- replaceVChanSerial v2 - return $ VPair nv1 nv2 - VFunc penv a b -> do - newpenv <- replaceVChanSerialPEnv penv - return $ VFunc newpenv a b - VDynCast v g -> do - nv <- replaceVChanSerial v - return $ VDynCast nv g - VFuncCast v a b -> do - nv <- replaceVChanSerial v - return $ VFuncCast nv a b - VRec penv a b c d -> do - newpenv <- replaceVChanSerialPEnv penv - return $ VRec newpenv a b c d - VNewNatRec penv a b c d e f g -> do - newpenv <- replaceVChanSerialPEnv penv - return $ VNewNatRec newpenv a b c d e f g - VChanSerial r w p o c -> do - putStrLn "Attempting to deserialize a VChanSerial" - networkconnection <- createNetworkConnectionS r w p o c - return $ VChan networkconnection - _ -> return input - where - replaceVChanSerialPEnv :: [(String, Value)] -> IO [(String, Value)] - replaceVChanSerialPEnv [] = return [] - replaceVChanSerialPEnv (x:xs) = do - newval <- replaceVChanSerial $ snd x - rest <- replaceVChanSerialPEnv xs - return $ (fst x, newval):rest - replaceVChan :: Value -> IO Value replaceVChan input = case input of VSend v -> do @@ -152,8 +108,7 @@ replaceVChan input = case input of VNewNatRec penv a b c d e f g -> do newpenv <- replaceVChanPEnv penv return $ VNewNatRec newpenv a b c d e f g - VChan nc -> do - putStrLn "Attempting to serialize a VChan" + VChan nc _ -> do (r, rl, w, wl, pid, oid, h, p) <- serializeNetworkConnection nc return $ VChanSerial (r, rl) (w, wl) pid oid (h, p) _ -> return input diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index 25e0318..7732095 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -11,7 +11,7 @@ data ConnectionState = Connected {csHostname :: String, csPort :: String} | Disconnected | Emulated | RedirectRequest {csHostname :: String, csPort :: String} -- Asks to redirect to this connection - deriving Eq + deriving (Eq, Show) newNetworkConnection :: String -> String -> String -> String -> IO (NetworkConnection a) diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index 5983e1f..c0a30ec 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -3,24 +3,17 @@ module Networking.Serialize where -import Control.Monad.IO.Class import Control.Concurrent.Chan as Chan import qualified Control.Concurrent.MVar as MVar import Syntax import Kinds -import qualified Syntax as S import Data.Set -import Foreign.C (eNODEV, e2BIG) -import Control.Concurrent (getChanContents) import Control.Exception import ProcessEnvironment import Networking.Messages import qualified Networking.DirectionalConnection as DC import qualified Networking.NetworkConnection as NCon import qualified Data.Maybe -import qualified Data.Map as Map -import qualified Network.Socket as Sock -import qualified Data.ByteString as DC import qualified Networking.DirectionalConnection as NCon @@ -55,7 +48,6 @@ instance Serializable Messages where ChangePartnerAddress p h port -> serializeLabeledEntryMulti "NChangePartnerAddress" p $ sNext h $ sLast port RequestClose p -> serializeLabeledEntry "NRequestClose" p --- instance (Serializable a => Serializable (NCon.NetworkConnection a)) where instance Serializable (NCon.NetworkConnection Value) where serialize con = do constate <- MVar.readMVar $ NCon.ncConnectionState con @@ -65,8 +57,6 @@ instance Serializable (NCon.NetworkConnection Value) where serializeLabeledEntryMulti "SNetworkConnection" (NCon.ncRead con) $ sNext (NCon.ncWrite con) $ sNext (Data.Maybe.fromMaybe "" $ NCon.ncPartnerUserID con) $ sNext (Data.Maybe.fromMaybe "" $ NCon.ncOwnUserID con) $ sLast constate - --- instance (Serializable a => Serializable (NCon.DirectionalConnection a)) where instance Serializable (NCon.DirectionalConnection Value) where serialize dcon = do (msg, msgUnread) <- DC.serializeConnection dcon @@ -77,8 +67,6 @@ instance Serializable (NCon.DirectionalConnection Value) where instance Serializable NCon.ConnectionState where serialize = \case NCon.Connected hostname port -> serializeLabeledEntryMulti "SConnected" hostname $ sLast port - -- NCon.Disconnected -> return "SDisconnected" - -- NCon.Emulated -> return "SEmulated" _ -> throw $ UnserializableException "VChan can only be serialized when in Connected mode" @@ -99,39 +87,8 @@ instance Serializable Value where VNewNatRec env f n tid ty ez x es -> serializeLabeledEntryMulti "VNewNatRec" env $ sNext f $ sNext n $ sNext tid $ sNext ty $ sNext ez $ sNext x $ sLast es VServerSocket {} -> throw $ UnserializableException "VServerSocket" - VChan nc -> serializeLabeledEntry "VChan" nc + VChan nc _-> serializeLabeledEntry "VChan" nc VChanSerial r w p o c -> serializeLabeledEntryMulti "VChanSerial" r $ sNext w $ sNext p $ sNext o $ sLast c - -- VChan {} -> throw $ UnserializableException "VChan" - {-VChan cc -> do - putStrLn "Trying to serialize VChan" - channelstate <- MVar.readMVar (ccChannelState cc) - case channelstate of - Connected mvarinfomap -> do - readList <- DC.allMessages (ccRead cc) - putStrLn "Read all incoming messages" - let readStartUnreadMVar = DC.messagesUnreadStart (ccRead cc) - readStartUnread <- MVar.readMVar readStartUnreadMVar - putStrLn "Read unreadpoint of incoming messages" - - writeList <- DC.allMessages (ccWrite cc) - putStrLn "Read all outgoing messages" - let writeStartUnreadMVar = DC.messagesUnreadStart (ccWrite cc) - writeStartUnread <- MVar.readMVar writeStartUnreadMVar - putStrLn "Read unreadpoint of outgoing messages" - - let partnerUserID = Data.Maybe.fromMaybe "" (ccPartnerUserID cc) - let ownUserID = Data.Maybe.fromMaybe "" (ccOwnUserID cc) - - putStrLn "Aquired all but connection address" - infomap <- MVar.readMVar mvarinfomap - let maybeconnectioninfo = Map.lookup partnerUserID infomap - case maybeconnectioninfo of - Nothing -> throw $ UnserializableException "VChan can only be serialized when in Connected mode" - Just connectioninfo -> do - case ciAddr connectioninfo of - Sock.SockAddrInet port hostname -> serializeLabeledEntryMulti "VChan" readList $ sNext readStartUnread $ sNext writeList $ sNext writeStartUnread $ sNext partnerUserID $ sNext ownUserID $ sNext (show port) $ sLast (show hostname) - _ -> throw $ UnserializableException "VChan currently only works over IPv4" - _ -> throw $ UnserializableException "VChan can only be serialized when in Connected mode"-} instance Serializable Multiplicity where serialize = \case @@ -208,12 +165,7 @@ instance Serializable Literal where LString s -> serializeLabeledEntry "LString" s instance Serializable FuncType where - serialize (FuncType env s t1 t2) = serializeLabeledEntryMulti "SFuncType" env $ sNext s $ sNext t1 $ sLast t2 -- do - -- envs <- serialize env - -- ss <- serialize s - -- t1s <- serialize t1 - -- t2s <- serialize t2 - -- return $ "SFuncType (" ++ envs ++ ") (" ++ ss ++ ") (" ++ t1s ++ ") (" ++ t2s ++ ")" + serialize (FuncType env s t1 t2) = serializeLabeledEntryMulti "SFuncType" env $ sNext s $ sNext t1 $ sLast t2 instance Serializable GType where serialize = \case diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index d114ae2..77c3f2f 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -25,12 +25,8 @@ import qualified Networking.DirectionalConnection as ND import qualified Networking.Client as NClient import Networking.NetworkConnection -import qualified Control.Concurrent as MVar -import Networking.NetworkConnection (newNetworkConnection, NetworkConnection (ncConnectionState, ncOwnUserID, ncRecievedRequestClose)) -import Networking.Messages (Messages(Introduce, RequestSync, SyncIncoming)) -import qualified Control.Concurrent as MVar -import qualified Control.Concurrent as MVar import qualified Networking.Common as NC +import qualified Config createServer :: Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), MVar.MVar [(String, Syntax.Type)]) createServer port = do @@ -47,7 +43,6 @@ createServer port = do liftIO $ listen sock 2 mvar <- MVar.newEmptyMVar MVar.putMVar mvar Map.empty - -- chan <- Chan.newChan clientlist <- MVar.newEmptyMVar MVar.putMVar clientlist [] forkIO $ acceptClients mvar clientlist sock @@ -55,9 +50,9 @@ createServer port = do acceptClients :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> Socket -> IO () acceptClients mvar clientlist socket = do - putStrLn "Waiting for clients" + Config.traceIO "Waiting for clients" clientsocket <- accept socket - putStrLn "Accepted new client" + Config.traceIO "Accepted new client" forkIO $ acceptClient mvar clientlist clientsocket acceptClients mvar clientlist socket @@ -68,16 +63,16 @@ acceptClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVa acceptClient mvar clientlist clientsocket = do hdl <- NC.getHandle $ fst clientsocket message <- hGetLine hdl - putStrLn $ "Recieved message:" ++ message + Config.traceIO $ "Recieved message:" ++ message case VT.runAlex message VG.parseMessages of -- case VT.runAlex message VG.parseValues of - Left err -> putStrLn $ "Error during recieving a networkmessage: "++err - Right deserialmessages -> do + Left err -> Config.traceIO $ "Error during recieving a networkmessage: "++err + Right deserialmessages -> do let userid = getPartnerID deserialmessages netcon <- MVar.takeMVar mvar redirectRequest <- checkRedirectRequest netcon userid MVar.putMVar mvar netcon - if redirectRequest then sendRedirect hdl netcon userid else do + if redirectRequest then sendRedirect hdl netcon userid else do case deserialmessages of NewValue userid val -> do handleNewValue mvar userid val @@ -93,28 +88,36 @@ acceptClient mvar clientlist clientsocket = do handleRequestClose mvar userid _ -> do serial <- NSerialize.serialize deserialmessages - putStrLn $ "Error unsupported networkmessage: "++ serial + Config.traceIO $ "Error unsupported networkmessage: "++ serial NC.sendMessage Messages.Okay hdl hClose hdl checkRedirectRequest :: Map.Map String (NetworkConnection Value) -> String -> IO Bool -checkRedirectRequest ncmap userid = case Map.lookup userid ncmap of - Nothing -> return False - Just networkconnection -> do - constate <- MVar.readMVar $ ncConnectionState networkconnection - case constate of - RedirectRequest _ _ -> return True - _ -> return False +checkRedirectRequest ncmap userid = do + putStrLn $ "Checking redirect request of user: " ++ userid + case Map.lookup userid ncmap of + Nothing -> do + putStrLn $ "Warning user " ++ userid ++ " not found when processing redirect request!" + return False + Just networkconnection -> do + putStrLn $ "Trying to check connectionstate of user: " ++ userid + constate <- MVar.readMVar $ ncConnectionState networkconnection + print constate + case constate of + RedirectRequest _ _ -> return True + _ -> return False sendRedirect :: Handle -> Map.Map String (NetworkConnection Value) -> String -> IO () -sendRedirect handle ncmap userid = case Map.lookup userid ncmap of - Nothing -> return () - Just networkconnection -> do - constate <- MVar.readMVar $ ncConnectionState networkconnection - case constate of - RedirectRequest host port -> NC.sendMessage (Messages.Redirect host port) handle - _ -> return () +sendRedirect handle ncmap userid = do + putStrLn "WARNING: Trying to send redirect!" + case Map.lookup userid ncmap of + Nothing -> return () + Just networkconnection -> do + constate <- MVar.readMVar $ ncConnectionState networkconnection + case constate of + RedirectRequest host port -> NC.sendMessage (Messages.Redirect host port) handle + _ -> return () @@ -125,7 +128,7 @@ handleNewValue mvar userid val = do Just networkconnection -> do ND.writeMessage (ncRead networkconnection) val Nothing -> do - putStrLn "Error during recieving a networkmessage: Introduction is needed prior to sending values!" + Config.traceIO "Error during recieving a networkmessage: Introduction is needed prior to sending values!" MVar.putMVar mvar networkconnectionmap handleIntroduceClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Syntax.Type -> IO () @@ -133,7 +136,7 @@ handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype networkconnectionmap <- MVar.takeMVar mvar case Map.lookup userid networkconnectionmap of Just networkconnection -> do - putStrLn "Error during recieving a networkmessage: Already introduced to this client!" + Config.traceIO "Error during recieving a networkmessage: Already introduced to this client!" MVar.putMVar mvar networkconnectionmap Nothing -> case snd clientsocket of -- This client is new SockAddrInet port hostname -> do @@ -147,7 +150,7 @@ handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype MVar.putMVar clientlist $ clientlistraw ++ [(userid, syntype)] _ -> do - putStrLn "Error during recieving a networkmessage: only ipv4 is currently supported!" + Config.traceIO "Error during recieving a networkmessage: only ipv4 is currently supported!" MVar.putMVar mvar networkconnectionmap handleChangePartnerAddress :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> IO () @@ -158,12 +161,16 @@ handleChangePartnerAddress mvar userid hostname port = do let constate = ncConnectionState networkconnection _ <- MVar.takeMVar constate MVar.putMVar constate $ Networking.NetworkConnection.Connected hostname port + -- For some reason constate doesn't seem to properly apply MVar.putMVar mvar networkconnectionmap + -- MVar.putMVar mvar $ Map.insert userid networkconnection networkconnectionmap + -- Maybe reinsert the networkconnection does the trick -- Sync and request sync - NClient.sendNetworkMessage networkconnection (RequestSync $ Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) - writevals <- ND.allMessages $ ncWrite networkconnection - NClient.sendNetworkMessage networkconnection (SyncIncoming (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) writevals) + -- NClient.sendNetworkMessage networkconnection (RequestSync $ Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) + -- writevals <- ND.allMessages $ ncWrite networkconnection + -- NClient.sendNetworkMessage networkconnection (SyncIncoming (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) writevals) + putStrLn "Changed partner address!" Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that @@ -182,14 +189,14 @@ handleSyncIncoming mvar userid values = do case Map.lookup userid networkconnectionmap of Just networkconnection -> do -- Change to current network address ND.syncMessages (ncRead networkconnection) values - Nothing -> return () + Nothing -> return () handleRequestClose :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> IO () handleRequestClose mvar userid = do networkconnectionmap <- MVar.takeMVar mvar case Map.lookup userid networkconnectionmap of Just networkconnection -> do - _ <- MVar.takeMVar $ ncRecievedRequestClose networkconnection + _ <- MVar.takeMVar $ ncRecievedRequestClose networkconnection MVar.putMVar (ncRecievedRequestClose networkconnection) True Nothing -> return () MVar.putMVar mvar networkconnectionmap @@ -205,25 +212,21 @@ waitForIntroduction handle serverid = do message <- hGetLine handle case VT.runAlex message VG.parseMessages of Left err -> do - putStrLn $ "Error during client introduction: "++err + Config.traceIO $ "Error during client introduction: "++err throw $ NC.NoIntroductionException message Right deserial -> case deserial of Introduce partner -> do NC.sendMessage (Messages.Introduce serverid) handle return partner _ -> do - putStrLn $ "Error during client introduction, wrong message: "++ message + Config.traceIO $ "Error during client introduction, wrong message: "++ message throw $ NC.NoIntroductionException message findFittingClientMaybe :: MVar.MVar [(String, Syntax.Type)] -> Syntax.Type -> IO (Maybe String) findFittingClientMaybe clientlist desiredType = do clientlistraw <- MVar.takeMVar clientlist let newclientlistrawAndReturn = fFCMRaw clientlistraw desiredType - -- putStrLn "findFittingClientMaybe:" - -- print clientlistraw - -- putStrLn $ "Desired Type: " ++ show desiredType - -- For some reason these prints are needed for it to work. Probably some timing thing - -- Also we send the name of the type but not the type itself, this needs to change + -- We send the name of the type but not the type itself, this needs to change MVar.putMVar clientlist $ fst newclientlistrawAndReturn return $ snd newclientlistrawAndReturn where @@ -239,6 +242,46 @@ findFittingClient clientlist desiredType = do mbystring <- findFittingClientMaybe clientlist desiredType case mbystring of Just userid -> return userid - Nothing -> do + Nothing -> do threadDelay 10000 -- Sleep for 10 ms to not hammer the CPU - findFittingClient clientlist desiredType \ No newline at end of file + findFittingClient clientlist desiredType + + +replaceVChanSerial :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> Value -> IO Value +replaceVChanSerial mvar input = case input of + VSend v -> do + nv <- replaceVChanSerial mvar v + return $ VSend nv + VPair v1 v2 -> do + nv1 <- replaceVChanSerial mvar v1 + nv2 <- replaceVChanSerial mvar v2 + return $ VPair nv1 nv2 + VFunc penv a b -> do + newpenv <- replaceVChanSerialPEnv mvar penv + return $ VFunc newpenv a b + VDynCast v g -> do + nv <- replaceVChanSerial mvar v + return $ VDynCast nv g + VFuncCast v a b -> do + nv <- replaceVChanSerial mvar v + return $ VFuncCast nv a b + VRec penv a b c d -> do + newpenv <- replaceVChanSerialPEnv mvar penv + return $ VRec newpenv a b c d + VNewNatRec penv a b c d e f g -> do + newpenv <- replaceVChanSerialPEnv mvar penv + return $ VNewNatRec newpenv a b c d e f g + VChanSerial r w p o c -> do + networkconnection <- createNetworkConnectionS r w p o c + ncmap <- MVar.takeMVar mvar + MVar.putMVar mvar $ Map.insert p networkconnection ncmap + NClient.sendNetworkMessage networkconnection $ RequestSync o + return $ VChan networkconnection mvar + _ -> return input + where + replaceVChanSerialPEnv :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> [(String, Value)] -> IO [(String, Value)] + replaceVChanSerialPEnv mvar [] = return [] + replaceVChanSerialPEnv mvar (x:xs) = do + newval <- replaceVChanSerial mvar $ snd x + rest <- replaceVChanSerialPEnv mvar xs + return $ (fst x, newval):rest \ No newline at end of file diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index 4f0b71a..3a9924d 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -11,6 +11,8 @@ import Data.Map as Map import qualified Data.Set as Set import Kinds (Multiplicity(..)) +import qualified Data.Maybe + import Networking.DirectionalConnection import qualified Networking.NetworkConnection as NCon -- import qualified Networking.Common as NC @@ -53,7 +55,8 @@ data Value | VInt Int | VDouble Double | VString String - | VChan (NCon.NetworkConnection Value) + | VChan (NCon.NetworkConnection Value) (MVar.MVar (Map.Map String (NCon.NetworkConnection Value))) --Maybe a "used" mvar to notify that this vchan should no longer be used + -- This is exclusively used to add VChanSerials into the map when in the interpreter | VChanSerial ([Value], Int) ([Value], Int) String String (String, String) | VSend Value | VPair Value Value -- pair of ids that map to two values @@ -67,32 +70,36 @@ data Value -- Own Port Number deriving Eq +disableOldVChan v = return v +disableVChan v = return v +disableVChans v = return v + +{- disableOldVChan :: Value -> IO Value disableOldVChan value = case value of - VChan nc -> do + VChan nc mvar -> do + ncmap <- MVar.takeMVar mvar constate <- MVar.newEmptyMVar oldconstate <- MVar.takeMVar $ NCon.ncConnectionState nc MVar.putMVar constate oldconstate MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected - let newNC = NCon.NetworkConnection (NCon.ncRead nc) (NCon.ncWrite nc) (NCOn.ncPartnerUserID nc) (NCon.ncOwnUserID nc) constate (NCon.ncRecievedRequestClose nc) - return $ VChan newNC + let newNC = NCon.NetworkConnection (NCon.ncRead nc) (NCon.ncWrite nc) (NCon.ncPartnerUserID nc) (NCon.ncOwnUserID nc) constate (NCon.ncRecievedRequestClose nc) + MVar.putMVar mvar $ Map.insert (Data.Maybe.fromMaybe "" (NCon.ncPartnerUserID nc)) newNC ncmap + return $ VChan newNC mvar _ -> return value disableVChan :: Value -> IO () disableVChan value = case value of - VChan nc -> do - -- constate <- MVar.newEmptyMVar - -- MVar.putMVar constate NCon.Disconnected - -- let newNC = NCon.NetworkConnection (NCon.ncRead nc) (NCon.ncWrite nc) (NCOn.ncPartnerUserID nc) (NCon.ncOwnUserID nc) constate - putStrLn "Taking MVar" - _ <- MVar.tryTakeMVar $ NCon.ncConnectionState nc --I dont fully understand why this mvar isnt filled but lets bypass this problem - putStrLn "MVar cleared" - MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected - putStrLn "MVar written" - -- return $ VChan nc - -- return $ VChan newNC - _ -> return () --return value + VChan nc mvar -> do + mbystate <- MVar.tryTakeMVar $ NCon.ncConnectionState nc --I dont fully understand why this mvar isnt filled but lets bypass this problem + case mbystate of + Nothing -> MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected + Just state -> case state of + NCon.Connected _ _ -> MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected + NCon.Emulated -> MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected + _ -> MVar.putMVar (NCon.ncConnectionState nc) state + _ -> return () @@ -136,8 +143,7 @@ disableVChans input = case input of rest <- disableVChansPEnv xs return () -- return $ (fst x, newval):rest - - +-} instance Show Value where diff --git a/src/SerializeValues.hs b/src/SerializeValues.hs deleted file mode 100644 index 74a828b..0000000 --- a/src/SerializeValues.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} - -module SerializeValues where - -import ProcessEnvironment -import Syntax -import Kinds -import qualified Syntax as S -import Data.Set - -class Serializable a where - serialize :: a -> String - -instance Serializable Value where - serialize = \case - VUnit -> "VUnit" - VLabel s -> "VLabel (" ++ serialize s ++ ")" - VInt i -> "VInt (" ++ serialize i ++ ")" - VDouble d -> "VDouble (" ++ serialize d ++ ")" - VString s -> "VString (" ++ serialize s ++ ")" --- VChan c1 c2 -> "VChan (" ++ serialize c1 ++ ") (" ++ serialize c2 ++ ")" - VSend v -> "VSend (" ++ serialize v ++ ")" - VPair a b -> "VPair (" ++ serialize a ++ ") (" ++ serialize b ++ ")" - VType t -> "VType (" ++ serialize t ++ ")" - VFunc env s exp -> "VFunc (" ++ serialize env ++ ") (" ++ serialize s ++ ") (" ++ serialize exp++")" - VDynCast v t -> "VDynCast (" ++ serialize v ++ ") (" ++ serialize t ++ ")" - VFuncCast v ft1 ft2 -> "VFuncCast (" ++ serialize v ++ ") (" ++ serialize ft1 ++ ") (" ++ serialize ft2 ++ ")" - VRec env f x e1 e0 -> "VRec (" ++ serialize env ++") (" ++ serialize f ++ ") (" ++ serialize x ++ ") (" ++ serialize e1 ++ ") (" ++ serialize e0 ++ ")" - VNewNatRec env f n tid ty ez x es -> "VNewNatRec (" ++ serialize env ++ ") (" ++ serialize f ++ ") (" ++ serialize n ++ ") (" ++ serialize tid ++ - ") (" ++ serialize ty ++ ") (" ++ serialize ez ++ ") (" ++ serialize x ++ ") ("++ serialize es++ ")" - -instance Serializable Type where - serialize = \case - TUnit -> "TUnit" - TInt -> "TInt" - TDouble -> "TDouble" - TBot -> "TBot" - TDyn -> "TDyn" - TNat -> "TNat" - TString -> "TString" - TNatLeq i -> "TNatLeq (" ++ serialize i ++ ")" - TNatRec e t1 ident t2 -> "TNatRec (" ++ serialize e ++") (" ++ serialize t1 ++ ") (" ++ serialize ident ++ ") (" ++ serialize t2 ++ ")" - TVar b ident -> "TVar (" ++ serialize b ++ ") (" ++ serialize ident ++ ")" - TAbs ident t1 t2 -> "TAbs (" ++ serialize ident ++ ") (" ++ serialize t1 ++ ") (" ++ serialize t2 ++ ")" - TName b ident -> "TName (" ++ serialize b ++ ") (" ++ serialize ident ++ ")" - TLab arr -> "TLab (" ++ serialize arr ++ ")" - TFun mult ident t1 t2 -> "TFun (" ++ show mult ++ ") (" ++ serialize ident ++ ") (" ++ serialize t1 ++ ") (" ++ serialize t2 ++ ")" - TPair ident t1 t2 -> "TPair (" ++ serialize ident ++ ") (" ++ serialize t1 ++ ") (" ++ serialize t2 ++ ")" - TSend ident t1 t2 -> "TSend (" ++ serialize ident ++ ") (" ++ serialize t1 ++ ") (" ++ serialize t2 ++ ")" - TRecv ident t1 t2 -> "TRecv (" ++ serialize ident ++ ") (" ++ serialize t1 ++ ") (" ++ serialize t2 ++ ")" - TCase e arr -> "TCase (" ++ serialize e ++ ") (" ++ serialize arr ++ ")" - TEqn e1 e2 t -> "TEqn (" ++ serialize e1 ++ ") (" ++ serialize e2 ++ ") (" ++ serialize t ++ ")" - TSingle ident -> "TSingle (" ++ serialize ident ++ ")" - -instance Serializable Exp where - serialize = \case - Let ident e1 e2 -> "ELet (" ++ serialize ident ++ ") (" ++ serialize e1 ++ ") (" ++ serialize e2 ++ ")" - Math mathop -> "EMath (" ++ serialize mathop ++ ")" - Lit l -> "ELit (" ++ serialize l ++ ")" - Succ e -> "ESucc (" ++ serialize e ++ ")" - NatRec e1 e2 ident1 ident2 ident3 t e3 -> "ENatRec (" ++ serialize e1 ++ ") (" ++ serialize e2 ++ ") (" ++ serialize ident1 ++ - ") (" ++ serialize ident2 ++ ") (" ++ serialize ident3 ++ ") (" ++ serialize t ++ - ") (" ++ serialize e3 ++ ")" - NewNatRec ident1 ident2 ident3 t e1 ident4 e2 -> "ENetNatRec (" ++ serialize ident1 ++ ") (" ++ serialize ident2 ++ - ") (" ++ serialize ident3++ ") (" ++ serialize t ++ ") (" ++ serialize e1 ++ - ") (" ++ serialize ident4 ++ ") (" ++ serialize e2 ++ ")" - Var ident -> "EVar (" ++ serialize ident ++ ")" - Lam mult ident t e -> "ELam (" ++ show mult ++ ") (" ++ serialize ident ++ ") (" ++ serialize t ++ ") (" ++ serialize e ++ ")" - Rec ident1 ident2 e1 e2 -> "ERec (" ++ serialize ident1 ++ ") (" ++ serialize ident2 ++ ") (" ++ serialize e1 ++ - ") (" ++ serialize e2 ++ ")" - App e1 e2 -> "EApp (" ++ serialize e1 ++ ") (" ++ serialize e2 ++ ")" - Pair mult ident e1 e2 -> "EPair (" ++ show mult ++ ") (" ++ serialize ident ++ ") (" ++ serialize e1 ++ - ") (" ++ serialize e2 ++ ")" - LetPair ident1 ident2 e1 e2 -> "ELetPair (" ++ serialize ident1 ++ ") (" ++ serialize ident2 ++ ") (" ++ serialize e1 ++ - ") (" ++ serialize e2 ++ ")" - Fst e -> "EFst (" ++ serialize e ++ ")" - Snd e -> "ESnd (" ++ serialize e ++ ")" - Fork e -> "EFork (" ++ serialize e ++ ")" - New t -> "ENew (" ++ serialize t ++ ")" - Send e -> "ESend (" ++ serialize e ++ ")" - Recv e -> "ERecv (" ++ serialize e ++ ")" - Case e arr -> "ECase (" ++ serialize e ++ ") (" ++ serialize arr ++ ")" - Cast e t1 t2 -> "ECast (" ++ serialize e ++ ") (" ++ serialize t1 ++ ") (" ++ serialize t2 ++ ")" - -instance Serializable (MathOp Exp) where - serialize = \case - Add e1 e2 -> "MAdd (" ++ serialize e1 ++ ") (" ++ serialize e2 ++ ")" - Sub e1 e2 -> "MSub (" ++ serialize e1 ++ ") (" ++ serialize e2 ++ ")" - Mul e1 e2 -> "MMul (" ++ serialize e1 ++ ") (" ++ serialize e2 ++ ")" - Div e1 e2 -> "MDiv (" ++ serialize e1 ++ ") (" ++ serialize e2 ++ ")" - Neg e -> "MNeg (" ++ serialize e ++ ")" - -instance Serializable Literal where - serialize = \case - LInt i -> "LInt (" ++ serialize i ++ ")" - LNat i -> "LNat (" ++ serialize i ++ ")" - LDouble d -> "LDouble (" ++ serialize d ++ ")" - LLab s -> "LLab (" ++ serialize s ++ ")" - LUnit -> "LUnit" - LString s -> "LString (" ++ serialize s ++ ")" - -instance Serializable FuncType where - serialize (FuncType env s t1 t2) = "SFuncType (" ++ serialize env ++ ") (" ++ serialize s ++ ") (" ++ serialize t1 ++ ") (" ++ serialize t2 ++ ")" - -instance Serializable GType where - serialize = \case - GUnit -> "GUnit" - GLabel lt -> "GLabel (" ++ serialize lt ++ ")" - GFunc mult -> "GFunc (" ++ show mult ++ ")" - GPair -> "GPair" - GNat -> "GNat" - GNatLeq i -> "GNatLeq (" ++ serialize i ++ ")" - GInt -> "GInt" - GDouble -> "GDouble" - GString -> "GString" - -instance {-# OVERLAPPING #-} Serializable String where - serialize s = "String:"++ show s - -instance Serializable Int where - serialize i = "Int:" ++ show i - -instance Serializable Integer where - serialize i = "Integer:" ++ show i - -instance Serializable Bool where - serialize b = "Bool:" ++ show b - -instance Serializable Double where - serialize d = "Double:" ++ show d - -instance (Serializable a => Serializable (Set a)) where - serialize as = "{" ++ serializeElements (elems as) ++ "}" - -instance {-# OVERLAPPABLE #-} (Serializable a => Serializable [a]) where - serialize arr = "["++ serializeElements arr ++"]" - -instance ((Serializable a, Serializable b) => Serializable (a, b)) where - serialize (s, t) = "((" ++ serialize s ++ ") (" ++ serialize t ++ "))" - -instance {-# OVERLAPPING #-} Serializable PEnv where - serialize arr = "PEnv ["++ serializeElements arr ++"]" - -instance {-# OVERLAPPING #-} Serializable PEnvEntry where - serialize (s, t) = "PEnvEntry (" ++ serialize s ++ ") (" ++ serialize t ++ ")" - -instance {-# OVERLAPPING #-} Serializable LabelType where - serialize as = "SLabelType {" ++ serializeElements (elems as) ++ "}" - -instance {-# OVERLAPPING #-} Serializable [(String, Exp)] where - serialize arr = "SStringExpArray [" ++ serializeElements arr ++ "]" - -instance {-# OVERLAPPING #-} Serializable [(String, Type)] where - serialize arr = "SStringTypeArray [" ++ serializeElements arr ++ "]" - -instance {-# OVERLAPPING #-} Serializable [String] where - serialize arr = "SStringArray [" ++ serializeElements arr ++ "]" - -instance {-# OVERLAPPING #-}Serializable [Value] where - serialize arr = "SValuesArray [" ++ serializeElements arr ++ "]" - -serializeElements :: Serializable a => [a] -> String -serializeElements [] = "" -serializeElements [x] = serialize x -serializeElements (x:xs) = serialize x ++ ", " ++ serializeElements xs \ No newline at end of file From 3e924d233d144df364b34342c3ad525d6a475bac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 19 Dec 2022 14:24:44 +0100 Subject: [PATCH 065/229] Fixed a bug with the end command --- src/Networking/Client.hs | 31 +++++++++++++++-------------- src/Networking/NetworkConnection.hs | 7 ++++++- src/Networking/Server.hs | 12 ++--------- 3 files changed, 24 insertions(+), 26 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index d952887..e40ee05 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -22,20 +22,23 @@ import GHC.Exception import qualified Syntax import qualified Networking.Common as NC import Networking.Messages (Messages(RequestClose)) +import qualified Networking.NetworkConnection as NCon sendMessage :: NetworkConnection Value -> Value -> IO () sendMessage networkconnection val = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port -> do - catch (tryToSend networkconnection hostname port val) $ printConErr hostname port + valcleaned <- NC.replaceVChan val + DC.writeMessage (ncWrite networkconnection) valcleaned + catch (tryToSend networkconnection hostname port val valcleaned) $ printConErr hostname port NCon.Disconnected -> Config.traceIO "Error when sending message: This channel is disconnected" NCon.Emulated -> DC.writeMessage (ncWrite networkconnection) val -- MVar.putMVar (ncConnectionState networkconnection) connectionstate -tryToSend :: NetworkConnection Value -> String -> String -> Value -> IO () -tryToSend networkconnection hostname port val = do +tryToSend :: NetworkConnection Value -> String -> String -> Value -> Value -> IO () +tryToSend networkconnection hostname port val valcleaned = do let hints = defaultHints { addrFlags = [] , addrSocketType = Stream @@ -45,9 +48,8 @@ tryToSend networkconnection hostname port val = do clientsocket <- NC.openSocketNC $ head addrInfo connect clientsocket $ addrAddress $ head addrInfo handle <- NC.getHandle clientsocket - valcleaned <- NC.replaceVChan val + NC.sendMessage (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) valcleaned) handle - DC.writeMessage (ncWrite networkconnection) valcleaned sendVChanMessages hostname port val -- This sends a ChangeNetworkPartner Message if appropriate disableVChans val -- Disables all sent VChans for the sending party @@ -59,7 +61,8 @@ tryToSend networkconnection hostname port val = do Okay -> Config.traceIO "Message okay" Redirect host port -> do Config.traceIO "Communication partner changed address, resending" - tryToSend networkconnection host port val + NCon.changePartnerAddress networkconnection host port + tryToSend networkconnection host port val valcleaned Nothing -> Config.traceIO "Error when recieving response" @@ -95,6 +98,7 @@ tryToSendNetworkMessage networkconnection hostname port message = do Okay -> Config.traceIO "Message okay" Redirect host port -> do Config.traceIO "Communication partner changed address, resending" + NCon.changePartnerAddress networkconnection host port tryToSendNetworkMessage networkconnection host port message Nothing -> Config.traceIO "Error when recieving response" @@ -151,18 +155,13 @@ sendVChanMessages newhost newport input = case input of closeConnection :: NetworkConnection Value -> IO () -closeConnection networkconnection = do - connectionstate <- MVar.readMVar $ ncConnectionState networkconnection +closeConnection con = do + connectionstate <- MVar.readMVar $ ncConnectionState con case connectionstate of NCon.Connected hostname port -> do - waitForAck networkconnection hostname port - NCon.Disconnected -> Config.traceIO "Error when sending message: This channel is disconnected" - NCon.Emulated -> pure () - where - waitForAck con hostname port = do connectionError <- MVar.newEmptyMVar MVar.putMVar connectionError False - catch ( tryToSendNetworkMessage networkconnection hostname port (RequestClose $ Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) ) (\exception -> do + catch ( tryToSendNetworkMessage con hostname port (RequestClose $ Data.Maybe.fromMaybe "" $ ncOwnUserID con) ) (\exception -> do printConErr hostname port exception _ <- MVar.takeMVar connectionError -- If we cannot communicate with them just close the connection MVar.putMVar connectionError True @@ -175,4 +174,6 @@ closeConnection networkconnection = do return () else do threadDelay 1000000 - waitForAck con hostname port \ No newline at end of file + closeConnection con + NCon.Disconnected -> Config.traceIO "Error when sending message: This channel is disconnected" + NCon.Emulated -> pure () diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index 7732095..1a98f48 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -57,4 +57,9 @@ serializeNetworkConnection nc = do Connected address port -> return (address, port) RedirectRequest address port -> return (address, port) _ -> return ("", "") - return (readList, readUnread, writeList, writeUnread, Data.Maybe.fromMaybe "" $ ncPartnerUserID nc, Data.Maybe.fromMaybe "" $ ncOwnUserID nc, address, port) \ No newline at end of file + return (readList, readUnread, writeList, writeUnread, Data.Maybe.fromMaybe "" $ ncPartnerUserID nc, Data.Maybe.fromMaybe "" $ ncOwnUserID nc, address, port) + +changePartnerAddress :: NetworkConnection a -> String -> String -> IO () +changePartnerAddress con hostname port = do + _ <- MVar.takeMVar $ ncConnectionState con + MVar.putMVar (ncConnectionState con) $ Connected hostname port \ No newline at end of file diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 77c3f2f..e8a08c5 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -27,6 +27,7 @@ import qualified Networking.Client as NClient import Networking.NetworkConnection import qualified Networking.Common as NC import qualified Config +import qualified Networking.NetworkConnection as NCon createServer :: Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), MVar.MVar [(String, Syntax.Type)]) createServer port = do @@ -158,18 +159,9 @@ handleChangePartnerAddress mvar userid hostname port = do networkconnectionmap <- MVar.takeMVar mvar case Map.lookup userid networkconnectionmap of Just networkconnection -> do -- Change to current network address - let constate = ncConnectionState networkconnection - _ <- MVar.takeMVar constate - MVar.putMVar constate $ Networking.NetworkConnection.Connected hostname port + NCon.changePartnerAddress networkconnection hostname port -- For some reason constate doesn't seem to properly apply MVar.putMVar mvar networkconnectionmap - -- MVar.putMVar mvar $ Map.insert userid networkconnection networkconnectionmap - -- Maybe reinsert the networkconnection does the trick - - -- Sync and request sync - -- NClient.sendNetworkMessage networkconnection (RequestSync $ Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) - -- writevals <- ND.allMessages $ ncWrite networkconnection - -- NClient.sendNetworkMessage networkconnection (SyncIncoming (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) writevals) putStrLn "Changed partner address!" Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that From 88030aedd42965c104cd13e16b1eb27b1b0d9fc5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 19 Dec 2022 15:02:48 +0100 Subject: [PATCH 066/229] Added check to test that every chan is unused --- src/Interpreter.hs | 64 +++++++++++++++++++++++-------------- src/Networking/Client.hs | 7 ++-- src/Networking/Common.hs | 2 +- src/Networking/Serialize.hs | 2 +- src/Networking/Server.hs | 5 ++- src/ProcessEnvironment.hs | 23 +++++++++---- 6 files changed, 68 insertions(+), 35 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 5e6a4e3..bbb2a48 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -49,6 +49,8 @@ import ProcessEnvironment (disableOldVChan) import Networking.NetworkConnection (NetworkConnection(ncPartnerUserID)) import qualified Control.Concurrent as MVar import qualified Control.Concurrent as MVar +import qualified Control.Concurrent as MVar +import qualified Control.Concurrent as MVar -- import qualified Networking.NetworkConnection as NCon -- import qualified Networking.NetworkConnection as NCon @@ -64,6 +66,7 @@ data InterpreterException | DeserializationException String | NotAnExpectedValueException String Value | CommunicationPartnerNotFoundException String + | VChanIsUsedException String deriving Eq instance Show InterpreterException where @@ -79,6 +82,7 @@ instance Show InterpreterException where (DeserializationException err) -> "DeserializationException: " ++ err (NotAnExpectedValueException expected val) -> "NotAnExpectedValueException: This expresion: (" ++ pshow val ++ ") is not of type: " ++ expected (CommunicationPartnerNotFoundException partner) -> "CommunicationPartnerNotFoundException: Partner:" ++ partner ++ " not found" + (VChanIsUsedException chan) -> "VChanIsUsedException: VChan " ++ chan ++ " is already used!" instance Exception InterpreterException @@ -174,27 +178,35 @@ eval = \case nc2 <- liftIO $ NCon.newEmulatedConnection w r mvar <- liftIO MVar.newEmptyMVar liftIO $ MVar.putMVar mvar Map.empty - return $ VPair (VChan nc1 mvar) $ VChan nc2 mvar + used1 <- liftIO MVar.newEmptyMVar + liftIO $ MVar.putMVar used1 False + used2 <- liftIO MVar.newEmptyMVar + liftIO $ MVar.putMVar used2 False + return $ VPair (VChan nc1 mvar used1) $ VChan nc2 mvar used2 Send e -> VSend <$> interpret' e -- Apply VSend to the output of interpret' e Recv e -> do - interpret' e >>= \v@(VChan ci mvar) -> do - let dcRead = NCon.ncRead ci - valunclean <- liftIO $ DC.readUnreadMessage dcRead - val <- liftIO $ NS.replaceVChanSerial mvar valunclean - liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e - - -- Disable the old channel and get a new one - newV <- liftIO $ disableOldVChan v - return $ VPair val newV + interpret' e >>= \v@(VChan ci mvar usedmvar) -> do + used <- liftIO $ MVar.readMVar usedmvar + if used then throw $ VChanIsUsedException $ show v else do + let dcRead = NCon.ncRead ci + valunclean <- liftIO $ DC.readUnreadMessage dcRead + val <- liftIO $ NS.replaceVChanSerial mvar valunclean + liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e + + -- Disable the old channel and get a new one + newV <- liftIO $ disableOldVChan v + return $ VPair val newV End e -> do liftIO $ C.traceIO "Trying to close a connection" - interpret' e >>= \v@(VChan ci mvar) -> do - liftIO $ C.traceIO $ "Trying to close connection with:" ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID ci) - liftIO $ NClient.closeConnection ci - - -- Disable the channel - _ <- liftIO $ disableOldVChan v - return v + interpret' e >>= \v@(VChan ci mvar usedmvar) -> do + used <- liftIO $ MVar.readMVar usedmvar + if used then throw $ VChanIsUsedException $ show v else do + liftIO $ C.traceIO $ "Trying to close connection with:" ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID ci) + liftIO $ NClient.closeConnection ci + + -- Disable the channel + _ <- liftIO $ disableOldVChan v + return v Case e cases -> interpret' e >>= \(VLabel s) -> interpret' $ fromJust $ lookup s cases Create e -> do liftIO $ C.traceIO "Creating socket!" @@ -222,7 +234,9 @@ eval = \case Nothing -> throw $ CommunicationPartnerNotFoundException newuser Just networkconnection -> do liftIO $ C.traceIO "Client successfully accepted!" - return $ VChan networkconnection mvar + used <- liftIO MVar.newEmptyMVar + liftIO $ MVar.putMVar used False + return $ VChan networkconnection mvar used _ -> throw $ NotAnExpectedValueException "VServerSocket" val Connect e0 t e1 e2-> do @@ -279,12 +293,14 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) let env' = extendEnv n1 (VInt (n-1)) (extendEnv f natrec env) R.local (const env') (interpret' es) -- interpretApp _ (VSend v@(VChan _ c handle _ _ _)) w = do -interpretApp _ (VSend v@(VChan cc _)) w = do - liftIO $ NClient.sendMessage cc w - - -- Disable old VChan - newV <- liftIO $ disableOldVChan v - return newV +interpretApp _ (VSend v@(VChan cc _ usedmvar)) w = do + used <- liftIO $ MVar.readMVar usedmvar + if used then throw $ VChanIsUsedException $ show v else do + liftIO $ NClient.sendMessage cc w + + -- Disable old VChan + newV <- liftIO $ disableOldVChan v + return newV interpretApp e _ _ = throw $ ApplicationException e interpretLit :: Literal -> Value diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index e40ee05..0154c87 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -23,6 +23,7 @@ import qualified Syntax import qualified Networking.Common as NC import Networking.Messages (Messages(RequestClose)) import qualified Networking.NetworkConnection as NCon +import qualified Control.Concurrent as MVar sendMessage :: NetworkConnection Value -> Value -> IO () sendMessage networkconnection val = do @@ -127,7 +128,9 @@ initialConnect mvar hostname port ownport syntype= do networkconnectionmap <- MVar.takeMVar mvar let newNetworkconnectionmap = Map.insert introductionanswer newConnection networkconnectionmap MVar.putMVar mvar newNetworkconnectionmap - return $ VChan newConnection mvar + used <- MVar.newEmptyMVar + MVar.putMVar used False + return $ VChan newConnection mvar used sendVChanMessages :: String -> String -> Value -> IO () sendVChanMessages newhost newport input = case input of @@ -140,7 +143,7 @@ sendVChanMessages newhost newport input = case input of VFuncCast v a b -> sendVChanMessages newhost newport v VRec penv a b c d -> sendVChanMessagesPEnv newhost newport penv VNewNatRec penv a b c d e f g -> sendVChanMessagesPEnv newhost newport penv - VChan nc _-> do + VChan nc _ _-> do sendNetworkMessage nc (Messages.ChangePartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID nc) newhost newport) _ <- MVar.takeMVar $ ncConnectionState nc putStrLn $ "Set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 6492dba..8a32276 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -108,7 +108,7 @@ replaceVChan input = case input of VNewNatRec penv a b c d e f g -> do newpenv <- replaceVChanPEnv penv return $ VNewNatRec newpenv a b c d e f g - VChan nc _ -> do + VChan nc _ _-> do (r, rl, w, wl, pid, oid, h, p) <- serializeNetworkConnection nc return $ VChanSerial (r, rl) (w, wl) pid oid (h, p) _ -> return input diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index c0a30ec..ee5d095 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -87,7 +87,7 @@ instance Serializable Value where VNewNatRec env f n tid ty ez x es -> serializeLabeledEntryMulti "VNewNatRec" env $ sNext f $ sNext n $ sNext tid $ sNext ty $ sNext ez $ sNext x $ sLast es VServerSocket {} -> throw $ UnserializableException "VServerSocket" - VChan nc _-> serializeLabeledEntry "VChan" nc + VChan nc _ _-> serializeLabeledEntry "VChan" nc VChanSerial r w p o c -> serializeLabeledEntryMulti "VChanSerial" r $ sNext w $ sNext p $ sNext o $ sLast c instance Serializable Multiplicity where diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index e8a08c5..a65222e 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -28,6 +28,7 @@ import Networking.NetworkConnection import qualified Networking.Common as NC import qualified Config import qualified Networking.NetworkConnection as NCon +import qualified Control.Concurrent as MVar createServer :: Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), MVar.MVar [(String, Syntax.Type)]) createServer port = do @@ -268,7 +269,9 @@ replaceVChanSerial mvar input = case input of ncmap <- MVar.takeMVar mvar MVar.putMVar mvar $ Map.insert p networkconnection ncmap NClient.sendNetworkMessage networkconnection $ RequestSync o - return $ VChan networkconnection mvar + used<- MVar.newEmptyMVar + MVar.putMVar used False + return $ VChan networkconnection mvar used _ -> return input where replaceVChanSerialPEnv :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> [(String, Value)] -> IO [(String, Value)] diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index 3a9924d..2d7ea63 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -55,8 +55,9 @@ data Value | VInt Int | VDouble Double | VString String - | VChan (NCon.NetworkConnection Value) (MVar.MVar (Map.Map String (NCon.NetworkConnection Value))) --Maybe a "used" mvar to notify that this vchan should no longer be used + | VChan (NCon.NetworkConnection Value) (MVar.MVar (Map.Map String (NCon.NetworkConnection Value))) (MVar.MVar Bool) --Maybe a "used" mvar to notify that this vchan should no longer be used -- This is exclusively used to add VChanSerials into the map when in the interpreter + -- This is to mark a vchan as used (true if used) | VChanSerial ([Value], Int) ([Value], Int) String String (String, String) | VSend Value | VPair Value Value -- pair of ids that map to two values @@ -70,9 +71,9 @@ data Value -- Own Port Number deriving Eq -disableOldVChan v = return v -disableVChan v = return v -disableVChans v = return v +-- disableOldVChan v = return v +-- disableVChan v = return v +-- disableVChans v = return v {- disableOldVChan :: Value -> IO Value @@ -87,11 +88,22 @@ disableOldVChan value = case value of MVar.putMVar mvar $ Map.insert (Data.Maybe.fromMaybe "" (NCon.ncPartnerUserID nc)) newNC ncmap return $ VChan newNC mvar _ -> return value +-} + +disableOldVChan :: Value -> IO Value +disableOldVChan value = case value of + VChan nc mvar used -> do + _ <- MVar.takeMVar used + MVar.putMVar used True + unused <- MVar.newEmptyMVar + MVar.putMVar unused False + return $ VChan nc mvar unused + _ -> return value disableVChan :: Value -> IO () disableVChan value = case value of - VChan nc mvar -> do + VChan nc mvar _ -> do mbystate <- MVar.tryTakeMVar $ NCon.ncConnectionState nc --I dont fully understand why this mvar isnt filled but lets bypass this problem case mbystate of Nothing -> MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected @@ -143,7 +155,6 @@ disableVChans input = case input of rest <- disableVChansPEnv xs return () -- return $ (fst x, newval):rest --} instance Show Value where From b32882086371b65bd1d8a89efd56396ed9b82c21 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 19 Dec 2022 17:19:38 +0100 Subject: [PATCH 067/229] Added example for dual handoff --- dev-examples/bidirhandoff/client.ldgvnw | 36 +++++++++++++++++++ .../bidirhandoff/clienthandoff.ldgvnw | 35 ++++++++++++++++++ dev-examples/bidirhandoff/server.ldgvnw | 35 ++++++++++++++++++ .../bidirhandoff/serverhandoff.ldgvnw | 34 ++++++++++++++++++ src/Networking/Client.hs | 2 +- src/Networking/Server.hs | 5 --- 6 files changed, 141 insertions(+), 6 deletions(-) create mode 100644 dev-examples/bidirhandoff/client.ldgvnw create mode 100644 dev-examples/bidirhandoff/clienthandoff.ldgvnw create mode 100644 dev-examples/bidirhandoff/server.ldgvnw create mode 100644 dev-examples/bidirhandoff/serverhandoff.ldgvnw diff --git a/dev-examples/bidirhandoff/client.ldgvnw b/dev-examples/bidirhandoff/client.ldgvnw new file mode 100644 index 0000000..ee8969b --- /dev/null +++ b/dev-examples/bidirhandoff/client.ldgvnw @@ -0,0 +1,36 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. ?Int. !Int. ?Int. Unit +type SendIntClient : ! ~ssn = !Int. ?Int. Unit +type SendSendIntClient : ! ~ssn = !SendIntClient. Unit +type SendIntServer : ! ~ssn = ?Int. !Int. Unit +type SendSendIntServer : ! ~ssn = !SendIntServer. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let = recv x in + let y = ((send x2) 41) in + let = recv y in + let y3 = end y2 in + (m + n) + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let c22 = (send c2) 1300 in + let = recv c22 in + let c32 = (send c3) 37 in + let c4 = end c32 in + (m + n) + +val main : Int +val main = + let sock = (create 4343) in + let con = (connect sock SendInt "127.0.0.1" 4242 ) in -- This cannot be localhost, since this might break on containerized images + let x = ((send con) 1) in + let = recv x in + let con2 = (connect sock SendSendIntClient "127.0.0.1" 4340) in + let con22 = ((send con2) x2) in + let con23 = end con22 in + (n) + diff --git a/dev-examples/bidirhandoff/clienthandoff.ldgvnw b/dev-examples/bidirhandoff/clienthandoff.ldgvnw new file mode 100644 index 0000000..1ef2008 --- /dev/null +++ b/dev-examples/bidirhandoff/clienthandoff.ldgvnw @@ -0,0 +1,35 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. ?Int. !Int. ?Int. Unit +type SendIntClient : ! ~ssn = !Int. ?Int. Unit +type SendSendIntClient : ! ~ssn = !SendIntClient. Unit +type SendIntServer : ! ~ssn = ?Int. !Int. Unit +type SendSendIntServer : ! ~ssn = !SendIntServer. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let = recv x in + let y = ((send x2) 41) in + let = recv y in + let y3 = end y2 in + (m + n) + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let c22 = (send c2) 1300 in + let = recv c22 in + let c32 = (send c3) 37 in + let c4 = end c32 in + (m + n) + +val main : Int +val main = + let sock = (create 4340) in + let con = (accept sock (dualof SendSendIntClient)) in -- This cannot be localhost, since this might break on containerized images + let = (recv con) in + let x = ((send talk) 41) in + let = recv x in + let con2 = end x2 in + (n) + diff --git a/dev-examples/bidirhandoff/server.ldgvnw b/dev-examples/bidirhandoff/server.ldgvnw new file mode 100644 index 0000000..4bfc166 --- /dev/null +++ b/dev-examples/bidirhandoff/server.ldgvnw @@ -0,0 +1,35 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. ?Int. !Int. ?Int. Unit +type SendIntClient : ! ~ssn = !Int. ?Int. Unit +type SendSendIntClient : ! ~ssn = !SendIntClient. Unit +type SendIntServer : ! ~ssn = ?Int. !Int. Unit +type SendSendIntServer : ! ~ssn = !SendIntServer. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let = recv x in + let y = ((send x2) 41) in + let = recv y in + let y3 = end y2 in + (m + n) + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let c22 = (send c2) 1300 in + let = recv c22 in + let c32 = (send c3) 37 in + let c4 = end c32 in + (m + n) + +val main : Int +val main = + let sock = (create 4242) in + let con = (accept sock (dualof SendInt)) in + let = recv con in + let c22 = (send c2) 1300 in + let con2 = (accept sock (SendSendIntServer)) in + let con3 = ((send con2) c22) in + let con4 = end con3 in + (m) diff --git a/dev-examples/bidirhandoff/serverhandoff.ldgvnw b/dev-examples/bidirhandoff/serverhandoff.ldgvnw new file mode 100644 index 0000000..cc1f1d7 --- /dev/null +++ b/dev-examples/bidirhandoff/serverhandoff.ldgvnw @@ -0,0 +1,34 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. ?Int. !Int. ?Int. Unit +type SendIntClient : ! ~ssn = !Int. ?Int. Unit +type SendSendIntClient : ! ~ssn = !SendIntClient. Unit +type SendIntServer : ! ~ssn = ?Int. !Int. Unit +type SendSendIntServer : ! ~ssn = !SendIntServer. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let = recv x in + let y = ((send x2) 41) in + let = recv y in + let y3 = end y2 in + (m + n) + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let c22 = (send c2) 1300 in + let = recv c22 in + let c32 = (send c3) 37 in + let c4 = end c32 in + (m + n) + +val main : Int +val main = + let sock = (create 4240) in + let con = (connect sock (dualof SendSendIntServer) "127.0.0.1" 4242) in + let = recv con in + let = recv talk in + let c22 = (send c2) 37 in + let con4 = end c22 in + (m) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 0154c87..ec861be 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -146,7 +146,7 @@ sendVChanMessages newhost newport input = case input of VChan nc _ _-> do sendNetworkMessage nc (Messages.ChangePartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID nc) newhost newport) _ <- MVar.takeMVar $ ncConnectionState nc - putStrLn $ "Set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport + Config.traceIO $ "Set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest newhost newport _ -> return () where diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index a65222e..d11536c 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -96,13 +96,10 @@ acceptClient mvar clientlist clientsocket = do checkRedirectRequest :: Map.Map String (NetworkConnection Value) -> String -> IO Bool checkRedirectRequest ncmap userid = do - putStrLn $ "Checking redirect request of user: " ++ userid case Map.lookup userid ncmap of Nothing -> do - putStrLn $ "Warning user " ++ userid ++ " not found when processing redirect request!" return False Just networkconnection -> do - putStrLn $ "Trying to check connectionstate of user: " ++ userid constate <- MVar.readMVar $ ncConnectionState networkconnection print constate case constate of @@ -112,7 +109,6 @@ checkRedirectRequest ncmap userid = do sendRedirect :: Handle -> Map.Map String (NetworkConnection Value) -> String -> IO () sendRedirect handle ncmap userid = do - putStrLn "WARNING: Trying to send redirect!" case Map.lookup userid ncmap of Nothing -> return () Just networkconnection -> do @@ -163,7 +159,6 @@ handleChangePartnerAddress mvar userid hostname port = do NCon.changePartnerAddress networkconnection hostname port -- For some reason constate doesn't seem to properly apply MVar.putMVar mvar networkconnectionmap - putStrLn "Changed partner address!" Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that From cbd08d80598c201c38d37b407a864c24228c3ca2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 20 Dec 2022 17:10:23 +0100 Subject: [PATCH 068/229] Better debug output --- exe/Main.hs | 3 +-- src/Config.hs | 21 +++++++++++------ src/Networking/Client.hs | 17 +++++++++++++- src/Networking/Common.hs | 8 +++---- src/Networking/Messages.hs | 23 +++++++++--------- src/Networking/Serialize.hs | 1 + src/Networking/Server.hs | 41 +++++++++++++++++---------------- src/Networking/UserID.hs | 4 ++-- src/ValueParsing/ValueGrammar.y | 2 ++ src/ValueParsing/ValueTokens.x | 2 ++ 10 files changed, 74 insertions(+), 48 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index 66859fe..f1ae463 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -196,7 +196,6 @@ interpret Interpreter{ interpreterInputs = inputs, interpreterGradual = gradual (\v -> "Error: " ++ show v) (\v -> "Result: " ++ show v) (res :: Either SomeException P.Value) - -- liftIO $ threadDelay 1000000 compile :: CompileOpts -> Action () compile co = do @@ -257,7 +256,7 @@ parseFile mpath = do Just fp -> (fp,) <$> readFile fp -- Print declarations for debug - msgInfo . show $ parseDecls src + -- msgInfo . show $ parseDecls src case parseDecls src of Left err -> Nothing <$ formatMsg MsgError (Just name) err diff --git a/src/Config.hs b/src/Config.hs index fa6467f..bb9abba 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -8,15 +8,17 @@ import Control.Monad.IO.Class selected :: String -> Bool selected ident = ident `elem` ["valueEquiv", "subtype"] -data DebugLevel = DebugNone | DebugAll +data DebugLevel = DebugNone | DebugNetwork | DebugAll deriving (Eq, Ord, Show) + debugLevel :: DebugLevel -debugLevel = DebugAll --- debugLevel = DebugNone +--debugLevel = DebugAll +debugLevel = DebugNetwork +--debugLevel = DebugNone trace :: String -> a -> a -trace s a | debugLevel > DebugNone = D.trace s a +trace s a | debugLevel > DebugNetwork = D.trace s a | otherwise = a traceOnly :: String -> String -> a -> a @@ -30,17 +32,22 @@ traceOnlyM ident s | otherwise = pure () traceM :: Applicative f => String -> f () -traceM s | debugLevel > DebugNone = D.traceM s +traceM s | debugLevel > DebugNetwork = D.traceM s | otherwise = pure () traceShowM :: (Show a, Applicative f) => a -> f () traceShowM = traceM . show traceIO :: MonadIO m => String -> m () -traceIO s | debugLevel > DebugNone = liftIO $ D.traceIO s +traceIO s | debugLevel > DebugNetwork = liftIO $ D.traceIO s + | otherwise = pure () + +traceNetIO :: MonadIO m => String -> m () +traceNetIO s | debugLevel > DebugNone = liftIO $ D.traceIO s | otherwise = pure () + traceSuccess :: (Pretty a, Applicative f) => a -> f () traceSuccess a - | debugLevel > DebugNone = traceM $ "Success: " ++ pshow a + | debugLevel > DebugNetwork = traceM $ "Success: " ++ pshow a | otherwise = traceM "Success" diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index ec861be..d4d04b8 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -24,6 +24,8 @@ import qualified Networking.Common as NC import Networking.Messages (Messages(RequestClose)) import qualified Networking.NetworkConnection as NCon import qualified Control.Concurrent as MVar +import qualified Config +import qualified Networking.Serialize as NSerialize sendMessage :: NetworkConnection Value -> Value -> IO () sendMessage networkconnection val = do @@ -40,6 +42,10 @@ sendMessage networkconnection val = do tryToSend :: NetworkConnection Value -> String -> String -> Value -> Value -> IO () tryToSend networkconnection hostname port val valcleaned = do + serializedValue <- NSerialize.serialize valcleaned + Config.traceNetIO $ "Sending message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection) ++ " to: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkconnection) + Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port + Config.traceNetIO $ " Message: " ++ serializedValue let hints = defaultHints { addrFlags = [] , addrSocketType = Stream @@ -80,6 +86,10 @@ sendNetworkMessage networkconnection message = do tryToSendNetworkMessage :: NetworkConnection Value -> String -> String -> Messages -> IO () tryToSendNetworkMessage networkconnection hostname port message = do + serializedMessage <- NSerialize.serialize message + Config.traceNetIO $ "Sending message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection) ++ " to: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkconnection) + Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port + Config.traceNetIO $ " Message: " ++ serializedMessage let hints = defaultHints { addrFlags = [] , addrSocketType = Stream @@ -122,6 +132,11 @@ initialConnect mvar hostname port ownport syntype= do NC.sendMessage (Messages.IntroduceClient ownuserid ownport syntype) handle introductionanswer <- NC.waitForServerIntroduction handle Config.traceIO "Finished Handshake" + + msgserial <- NSerialize.serialize $ Messages.IntroduceClient ownuserid ownport syntype + Config.traceNetIO $ "Sending message as: " ++ ownuserid ++ " to: " ++ introductionanswer + Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port + Config.traceNetIO $ " Message: " ++ msgserial hClose handle newConnection <- newNetworkConnection introductionanswer ownuserid hostname port @@ -146,7 +161,7 @@ sendVChanMessages newhost newport input = case input of VChan nc _ _-> do sendNetworkMessage nc (Messages.ChangePartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID nc) newhost newport) _ <- MVar.takeMVar $ ncConnectionState nc - Config.traceIO $ "Set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport + Config.traceNetIO $ "Set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest newhost newport _ -> return () where diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 8a32276..3723ba8 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -40,7 +40,7 @@ instance Exception ServerException sendMessage :: NSerialize.Serializable a => a -> Handle -> IO () sendMessage value handle = do serializedValue <- NSerialize.serialize value - Config.traceIO $ "Sending message:" ++ serializedValue + -- Config.traceIO $ "Sending message:" ++ serializedValue hPutStrLn handle (serializedValue ++" ") recieveMessage :: Handle -> IO (Maybe Messages) @@ -62,8 +62,6 @@ recieveResponse handle = do return Nothing Right deserialmessage -> return $ Just deserialmessage - - getHandle :: Socket -> IO Handle getHandle socket = do hdl <- socketToHandle socket ReadWriteMode @@ -73,12 +71,12 @@ getHandle socket = do waitForServerIntroduction :: Handle -> IO String waitForServerIntroduction handle = do message <- hGetLine handle - case VT.runAlex message VG.parseMessages of + case VT.runAlex message VG.parseResponses of Left err -> do Config.traceIO $ "Error during server introduction: "++err throw $ NoIntroductionException message Right deserial -> case deserial of - Introduce partner -> do + OkayIntroduce partner -> do return partner _ -> do Config.traceIO $ "Error during server introduction, wrong message: "++ message diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs index 3a365d4..3bc9f66 100644 --- a/src/Networking/Messages.hs +++ b/src/Networking/Messages.hs @@ -5,29 +5,30 @@ module Networking.Messages where import ProcessEnvironment import Syntax -type Partner = String +type UserID = String type Hostname = String type Port = String -- I need to add the Port to every introduction so I can answer oder alles muss mit einem okay quitiert werden, dann kann die antwort gesendet werden data Messages - = Introduce Partner - | IntroduceClient Partner Port Type - | IntroduceServer Partner - | NewValue Partner Value - | SyncIncoming Partner [Value] - | RequestSync Partner - | ChangePartnerAddress Partner Hostname Port - | RequestClose Partner + = Introduce UserID + | IntroduceClient UserID Port Type + | IntroduceServer UserID + | NewValue UserID Value + | SyncIncoming UserID [Value] + | RequestSync UserID + | ChangePartnerAddress UserID Hostname Port + | RequestClose UserID deriving Eq data Responses = Redirect Hostname Port | Okay | OkayClose + | OkayIntroduce UserID -getPartnerID :: Messages -> String -getPartnerID = \case +getUserID :: Messages -> String +getUserID = \case Introduce p -> p IntroduceClient p _ _ -> p IntroduceServer p -> p diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index ee5d095..6df09db 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -36,6 +36,7 @@ instance Serializable Responses where Redirect host port -> serializeLabeledEntryMulti "NRedirect" host $ sLast port Okay -> return "NOkay" OkayClose -> return "NOkayClose" + OkayIntroduce u -> serializeLabeledEntry "NOkayIntroduce" u instance Serializable Messages where serialize = \case diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index d11536c..3a3c23f 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -65,33 +65,46 @@ acceptClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVa acceptClient mvar clientlist clientsocket = do hdl <- NC.getHandle $ fst clientsocket message <- hGetLine hdl - Config.traceIO $ "Recieved message:" ++ message + -- Config.traceNetIO $ "Recieved message:" ++ message case VT.runAlex message VG.parseMessages of -- case VT.runAlex message VG.parseValues of Left err -> Config.traceIO $ "Error during recieving a networkmessage: "++err Right deserialmessages -> do - let userid = getPartnerID deserialmessages + let userid = getUserID deserialmessages netcon <- MVar.takeMVar mvar redirectRequest <- checkRedirectRequest netcon userid MVar.putMVar mvar netcon + case Map.lookup userid netcon of + Just networkcon -> do + Config.traceNetIO $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) + Nothing -> do + Config.traceNetIO "Recieved message from unknown connection!" + Config.traceNetIO $ " Message: " ++ message + if redirectRequest then sendRedirect hdl netcon userid else do case deserialmessages of NewValue userid val -> do handleNewValue mvar userid val + NC.sendMessage Messages.Okay hdl IntroduceClient userid clientport syntype-> do handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype + -- Okay message is handled in handle introduce ChangePartnerAddress userid hostname port -> do handleChangePartnerAddress mvar userid hostname port + NC.sendMessage Messages.Okay hdl RequestSync userid -> do handleRequestSync mvar userid + NC.sendMessage Messages.Okay hdl SyncIncoming userid values -> do handleSyncIncoming mvar userid values + NC.sendMessage Messages.Okay hdl RequestClose userid -> do handleRequestClose mvar userid + NC.sendMessage Messages.Okay hdl _ -> do serial <- NSerialize.serialize deserialmessages Config.traceIO $ "Error unsupported networkmessage: "++ serial - NC.sendMessage Messages.Okay hdl + NC.sendMessage Messages.Okay hdl hClose hdl checkRedirectRequest :: Map.Map String (NetworkConnection Value) -> String -> IO Bool @@ -101,7 +114,6 @@ checkRedirectRequest ncmap userid = do return False Just networkconnection -> do constate <- MVar.readMVar $ ncConnectionState networkconnection - print constate case constate of RedirectRequest _ _ -> return True _ -> return False @@ -142,7 +154,10 @@ handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype networkconnection <- newNetworkConnection userid serverid (hostaddressTypeToString hostname) clientport let newnetworkconnectionmap = Map.insert userid networkconnection networkconnectionmap MVar.putMVar mvar newnetworkconnectionmap - NC.sendMessage (Introduce serverid) hdl -- Answer with own serverid + -- NC.sendMessage (Introduce serverid) hdl -- Answer with own serverid + NC.sendMessage (Messages.OkayIntroduce serverid) hdl + repserial <- NSerialize.serialize $ Messages.OkayIntroduce serverid + Config.traceNetIO $ " Response to "++ userid ++ ": " ++ repserial -- Adds the new user to the users that can be accepted by the server clientlistraw <- MVar.takeMVar clientlist MVar.putMVar clientlist $ clientlistraw ++ [(userid, syntype)] @@ -150,6 +165,7 @@ handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype _ -> do Config.traceIO "Error during recieving a networkmessage: only ipv4 is currently supported!" MVar.putMVar mvar networkconnectionmap + NC.sendMessage Messages.Okay hdl handleChangePartnerAddress :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> IO () handleChangePartnerAddress mvar userid hostname port = do @@ -195,21 +211,6 @@ hostaddressTypeToString hostaddress = do let (a, b, c, d) = hostAddressToTuple hostaddress show a ++ "." ++ show b ++ "."++ show c ++ "." ++ show d -waitForIntroduction :: Handle -> String -> IO String -waitForIntroduction handle serverid = do - message <- hGetLine handle - case VT.runAlex message VG.parseMessages of - Left err -> do - Config.traceIO $ "Error during client introduction: "++err - throw $ NC.NoIntroductionException message - Right deserial -> case deserial of - Introduce partner -> do - NC.sendMessage (Messages.Introduce serverid) handle - return partner - _ -> do - Config.traceIO $ "Error during client introduction, wrong message: "++ message - throw $ NC.NoIntroductionException message - findFittingClientMaybe :: MVar.MVar [(String, Syntax.Type)] -> Syntax.Type -> IO (Maybe String) findFittingClientMaybe clientlist desiredType = do clientlistraw <- MVar.takeMVar clientlist diff --git a/src/Networking/UserID.hs b/src/Networking/UserID.hs index 8088936..f267bca 100644 --- a/src/Networking/UserID.hs +++ b/src/Networking/UserID.hs @@ -12,5 +12,5 @@ mapToChar val -- This is "probably" unique newRandomUserID :: IO String --- newRandomUserID = map mapToChar . take 8 . randomRs (0, 61) <$> getStdGen -newRandomUserID = map mapToChar . take 128 . randomRs (0, 61) <$> getStdGen +newRandomUserID = map mapToChar . take 8 . randomRs (0, 61) <$> newStdGen +-- newRandomUserID = map mapToChar . take 128 . randomRs (0, 61) <$> newStdGen diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 4e45a10..58a3570 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -126,6 +126,7 @@ import Networking.Messages nokay { T _ T.NOkay} nrequestclose { T _ T.NRequestClose } nokayclose { T _ T.NOkayClose} + nokayintroduce { T _ T.NOkayIntroduce } gunit { T _ T.GUnit } glabel { T _ T.GLabel } @@ -289,6 +290,7 @@ Messages : nintroduce '(' String ')' {Introduce $3} Responses : nredirect '(' String ')' '(' String ')' {Redirect $3 $6} | nokay {Okay} | nokayclose {OkayClose} + | nokayintroduce '(' String ')' {OkayIntroduce $3} PEnvEntry : penventry '(' String ')' '(' Values ')' {($3, $6)} diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index 2a6491c..c47f703 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -139,6 +139,7 @@ tokens :- "NOkay" { tok $ const NOkay } "NRequestClose" { tok $ const NRequestClose } "NOkayClose" { tok $ const NOkayClose } + "NOkayIntroduce" { tok $ const NOkayIntroduce } Double\:[\-]?[0-9]+[\.][0-9]+ { tok $ Double . read . (drop 7) } Int\:[\-]?[0-9]+ { tok $ Int . read . (drop 4)} @@ -264,6 +265,7 @@ data Token | NOkay | NRequestClose | NOkayClose + | NOkayIntroduce | String String | Int Int From e7792c83efde5fb582a563f040bdac129b7e969c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 20 Dec 2022 17:33:53 +0100 Subject: [PATCH 069/229] The client now waits for a server --- src/Networking/Client.hs | 5 +++++ src/Networking/Common.hs | 20 ++++++++++++++++++++ 2 files changed, 25 insertions(+) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index d4d04b8..5a3c359 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -119,6 +119,7 @@ printConErr hostname port err = Config.traceIO $ "Communication Partner " ++ hos initialConnect :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> Syntax.Type -> IO Value initialConnect mvar hostname port ownport syntype= do + {- let hints = defaultHints { addrFlags = [] , addrSocketType = Stream @@ -127,6 +128,8 @@ initialConnect mvar hostname port ownport syntype= do clientsocket <- NC.openSocketNC $ head addrInfo connect clientsocket $ addrAddress $ head addrInfo handle <- NC.getHandle clientsocket + -} + handle <- NC.getClientHandle hostname port ownuserid <- UserID.newRandomUserID Config.traceIO "Client connected: Introducing" NC.sendMessage (Messages.IntroduceClient ownuserid ownport syntype) handle @@ -147,6 +150,8 @@ initialConnect mvar hostname port ownport syntype= do MVar.putMVar used False return $ VChan newConnection mvar used + + sendVChanMessages :: String -> String -> Value -> IO () sendVChanMessages newhost newport input = case input of VSend v -> sendVChanMessages newhost newport v diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 3723ba8..41ff725 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -12,6 +12,7 @@ import Control.Concurrent import GHC.IO.Handle import Control.Monad.IO.Class import System.IO +import Control.Exception import qualified Control.Concurrent.Chan as Chan import qualified Control.Concurrent.MVar as MVar import ProcessEnvironment @@ -68,6 +69,25 @@ getHandle socket = do hSetBuffering hdl NoBuffering return hdl + +-- This waits until the handle is established +getClientHandle :: String -> String -> IO Handle +getClientHandle hostname port = do + catch ( do + let hints = defaultHints { + addrFlags = [] + , addrSocketType = Stream + } + addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port + clientsocket <- openSocketNC $ head addrInfo + connect clientsocket $ addrAddress $ head addrInfo + getHandle clientsocket) $ expredirect hostname port + where + expredirect :: String -> String -> IOException -> IO Handle + expredirect hostname port e = do + threadDelay 1000000 + getClientHandle hostname port + waitForServerIntroduction :: Handle -> IO String waitForServerIntroduction handle = do message <- hGetLine handle From da4f1aec7309424db6e843d7ec4c9233c5b1bdf7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 20 Dec 2022 19:29:11 +0100 Subject: [PATCH 070/229] Trying to simplify networking code --- src/Interpreter.hs | 2 - src/Networking/Client.hs | 101 ++++++++++++++++++++++++++++++-- src/Networking/Common.hs | 123 +++------------------------------------ src/Networking/Server.hs | 53 +++++++++++++++++ 4 files changed, 157 insertions(+), 122 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index bbb2a48..dda0de6 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -257,8 +257,6 @@ eval = \case _ -> throw $ NotAnExpectedValueException "VInt" portVal _ -> throw $ NotAnExpectedValueException "VString" addressVal _ -> throw $ NotAnExpectedValueException "VServerSocket" serversocket - where - openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) e -> throw $ NotImplementedException e -- Exp is only used for blame diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 5a3c359..0e717eb 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + module Networking.Client where import qualified Config @@ -27,12 +29,23 @@ import qualified Control.Concurrent as MVar import qualified Config import qualified Networking.Serialize as NSerialize + +newtype ClientException = NoIntroductionException String + deriving Eq + +instance Show ClientException where + show = \case + NoIntroductionException s -> "Partner didn't introduce itself, but sent: " ++ s + +instance Exception ClientException + + sendMessage :: NetworkConnection Value -> Value -> IO () sendMessage networkconnection val = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port -> do - valcleaned <- NC.replaceVChan val + valcleaned <- replaceVChan val DC.writeMessage (ncWrite networkconnection) valcleaned catch (tryToSend networkconnection hostname port val valcleaned) $ printConErr hostname port NCon.Disconnected -> Config.traceIO "Error when sending message: This channel is disconnected" @@ -61,7 +74,7 @@ tryToSend networkconnection hostname port val valcleaned = do disableVChans val -- Disables all sent VChans for the sending party Config.traceIO "Waiting for response" - mbyresponse <- NC.recieveResponse handle + mbyresponse <- recieveResponse handle hClose handle case mbyresponse of Just response -> case response of @@ -102,7 +115,7 @@ tryToSendNetworkMessage networkconnection hostname port message = do NC.sendMessage message handle Config.traceIO "Waiting for response" - mbyresponse <- NC.recieveResponse handle + mbyresponse <- recieveResponse handle hClose handle case mbyresponse of Just response -> case response of @@ -129,11 +142,11 @@ initialConnect mvar hostname port ownport syntype= do connect clientsocket $ addrAddress $ head addrInfo handle <- NC.getHandle clientsocket -} - handle <- NC.getClientHandle hostname port + handle <- getClientHandle hostname port ownuserid <- UserID.newRandomUserID Config.traceIO "Client connected: Introducing" NC.sendMessage (Messages.IntroduceClient ownuserid ownport syntype) handle - introductionanswer <- NC.waitForServerIntroduction handle + introductionanswer <- waitForServerIntroduction handle Config.traceIO "Finished Handshake" msgserial <- NSerialize.serialize $ Messages.IntroduceClient ownuserid ownport syntype @@ -200,3 +213,81 @@ closeConnection con = do closeConnection con NCon.Disconnected -> Config.traceIO "Error when sending message: This channel is disconnected" NCon.Emulated -> pure () + +recieveResponse :: Handle -> IO (Maybe Responses) +recieveResponse handle = do + message <- hGetLine handle + case VT.runAlex message VG.parseResponses of + Left err -> do + Config.traceIO $ "Error during recieving a networkmessage: "++err + return Nothing + Right deserialmessage -> return $ Just deserialmessage + + +-- This waits until the handle is established +getClientHandle :: String -> String -> IO Handle +getClientHandle hostname port = do + catch ( do + let hints = defaultHints { + addrFlags = [] + , addrSocketType = Stream + } + addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port + clientsocket <- NC.openSocketNC $ head addrInfo + connect clientsocket $ addrAddress $ head addrInfo + NC.getHandle clientsocket) $ expredirect hostname port + where + expredirect :: String -> String -> IOException -> IO Handle + expredirect hostname port e = do + threadDelay 1000000 + getClientHandle hostname port + +replaceVChan :: Value -> IO Value +replaceVChan input = case input of + VSend v -> do + nv <- replaceVChan v + return $ VSend nv + VPair v1 v2 -> do + nv1 <- replaceVChan v1 + nv2 <- replaceVChan v2 + return $ VPair nv1 nv2 + VFunc penv a b -> do + newpenv <- replaceVChanPEnv penv + return $ VFunc newpenv a b + VDynCast v g -> do + nv <- replaceVChan v + return $ VDynCast nv g + VFuncCast v a b -> do + nv <- replaceVChan v + return $ VFuncCast nv a b + VRec penv a b c d -> do + newpenv <- replaceVChanPEnv penv + return $ VRec newpenv a b c d + VNewNatRec penv a b c d e f g -> do + newpenv <- replaceVChanPEnv penv + return $ VNewNatRec newpenv a b c d e f g + VChan nc _ _-> do + (r, rl, w, wl, pid, oid, h, p) <- serializeNetworkConnection nc + return $ VChanSerial (r, rl) (w, wl) pid oid (h, p) + _ -> return input + where + replaceVChanPEnv :: [(String, Value)] -> IO [(String, Value)] + replaceVChanPEnv [] = return [] + replaceVChanPEnv (x:xs) = do + newval <- replaceVChan $ snd x + rest <- replaceVChanPEnv xs + return $ (fst x, newval):rest + +waitForServerIntroduction :: Handle -> IO String +waitForServerIntroduction handle = do + message <- hGetLine handle + case VT.runAlex message VG.parseResponses of + Left err -> do + Config.traceIO $ "Error during server introduction: "++err + throw $ NoIntroductionException message + Right deserial -> case deserial of + OkayIntroduce partner -> do + return partner + _ -> do + Config.traceIO $ "Error during server introduction, wrong message: "++ message + throw $ NoIntroductionException message \ No newline at end of file diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 41ff725..b970485 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -2,141 +2,34 @@ module Networking.Common where -import qualified Control.Exception as E -import qualified Data.ByteString.Char8 as C import Network.Socket -import Network.Socket.ByteString (recv, sendAll) -import Data.Map (Map) -import qualified Data.Map as Map -import Control.Concurrent import GHC.IO.Handle -import Control.Monad.IO.Class import System.IO -import Control.Exception -import qualified Control.Concurrent.Chan as Chan -import qualified Control.Concurrent.MVar as MVar -import ProcessEnvironment - import qualified Networking.Serialize as NSerialize -import Networking.Messages -import Control.Exception - import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG -import qualified Networking.DirectionalConnection as DC -import Networking.DirectionalConnection (DirectionalConnection) -import Networking.Serialize (Serializable (serialize)) -import Networking.NetworkConnection import qualified Config -newtype ServerException = NoIntroductionException String - deriving Eq - -instance Show ServerException where - show = \case - NoIntroductionException s -> "Partner didn't introduce itself, but sent: " ++ s - -instance Exception ServerException - sendMessage :: NSerialize.Serializable a => a -> Handle -> IO () sendMessage value handle = do serializedValue <- NSerialize.serialize value - -- Config.traceIO $ "Sending message:" ++ serializedValue hPutStrLn handle (serializedValue ++" ") -recieveMessage :: Handle -> IO (Maybe Messages) -recieveMessage handle = do - message <- hGetLine handle - case VT.runAlex message VG.parseMessages of - -- case VT.runAlex message VG.parseValues of - Left err -> do - Config.traceIO $ "Error during recieving a networkmessage: "++err - return Nothing - Right deserialmessage -> return $ Just deserialmessage - -recieveResponse :: Handle -> IO (Maybe Responses) -recieveResponse handle = do - message <- hGetLine handle - case VT.runAlex message VG.parseResponses of - Left err -> do - Config.traceIO $ "Error during recieving a networkmessage: "++err - return Nothing - Right deserialmessage -> return $ Just deserialmessage - getHandle :: Socket -> IO Handle getHandle socket = do hdl <- socketToHandle socket ReadWriteMode hSetBuffering hdl NoBuffering return hdl - --- This waits until the handle is established -getClientHandle :: String -> String -> IO Handle -getClientHandle hostname port = do - catch ( do - let hints = defaultHints { - addrFlags = [] - , addrSocketType = Stream - } - addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port - clientsocket <- openSocketNC $ head addrInfo - connect clientsocket $ addrAddress $ head addrInfo - getHandle clientsocket) $ expredirect hostname port - where - expredirect :: String -> String -> IOException -> IO Handle - expredirect hostname port e = do - threadDelay 1000000 - getClientHandle hostname port - -waitForServerIntroduction :: Handle -> IO String -waitForServerIntroduction handle = do +-- recieveMessage :: Handle -> IO (Maybe a) +recieveMessage :: Handle -> VT.Alex t -> b -> (String -> t -> IO b) -> IO b +recieveMessage handle grammar fallbackResponse messageHandler = do message <- hGetLine handle - case VT.runAlex message VG.parseResponses of + case VT.runAlex message grammar of Left err -> do - Config.traceIO $ "Error during server introduction: "++err - throw $ NoIntroductionException message - Right deserial -> case deserial of - OkayIntroduce partner -> do - return partner - _ -> do - Config.traceIO $ "Error during server introduction, wrong message: "++ message - throw $ NoIntroductionException message - -replaceVChan :: Value -> IO Value -replaceVChan input = case input of - VSend v -> do - nv <- replaceVChan v - return $ VSend nv - VPair v1 v2 -> do - nv1 <- replaceVChan v1 - nv2 <- replaceVChan v2 - return $ VPair nv1 nv2 - VFunc penv a b -> do - newpenv <- replaceVChanPEnv penv - return $ VFunc newpenv a b - VDynCast v g -> do - nv <- replaceVChan v - return $ VDynCast nv g - VFuncCast v a b -> do - nv <- replaceVChan v - return $ VFuncCast nv a b - VRec penv a b c d -> do - newpenv <- replaceVChanPEnv penv - return $ VRec newpenv a b c d - VNewNatRec penv a b c d e f g -> do - newpenv <- replaceVChanPEnv penv - return $ VNewNatRec newpenv a b c d e f g - VChan nc _ _-> do - (r, rl, w, wl, pid, oid, h, p) <- serializeNetworkConnection nc - return $ VChanSerial (r, rl) (w, wl) pid oid (h, p) - _ -> return input - where - replaceVChanPEnv :: [(String, Value)] -> IO [(String, Value)] - replaceVChanPEnv [] = return [] - replaceVChanPEnv (x:xs) = do - newval <- replaceVChan $ snd x - rest <- replaceVChanPEnv xs - return $ (fst x, newval):rest + Config.traceIO $ "Error during recieving a networkmessage: "++err + return fallbackResponse + Right deserialmessage -> messageHandler message deserialmessage --- openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) +openSocketNC :: AddrInfo -> IO Socket openSocketNC addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) \ No newline at end of file diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 3a3c23f..be048c7 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -60,6 +60,56 @@ acceptClients mvar clientlist socket = do acceptClients mvar clientlist socket +-- In the nothing case we shoud wait a few seconds for other messages to resolve the issue +acceptClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> IO () +acceptClient mvar clientlist clientsocket = do + hdl <- NC.getHandle $ fst clientsocket + NC.recieveMessage hdl VG.parseMessages () $ handleClient mvar clientlist clientsocket hdl + hClose hdl + + +handleClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> Messages -> IO () +handleClient mvar clientlist clientsocket hdl message deserialmessages = do + let userid = getUserID deserialmessages + netcon <- MVar.takeMVar mvar + redirectRequest <- checkRedirectRequest netcon userid + MVar.putMVar mvar netcon + case Map.lookup userid netcon of + Just networkcon -> do + Config.traceNetIO $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) + Nothing -> do + Config.traceNetIO "Recieved message from unknown connection!" + Config.traceNetIO $ " Message: " ++ message + + if redirectRequest then sendRedirect hdl netcon userid else do + case deserialmessages of + NewValue userid val -> do + handleNewValue mvar userid val + NC.sendMessage Messages.Okay hdl + IntroduceClient userid clientport syntype-> do + handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype + -- Okay message is handled in handle introduce + ChangePartnerAddress userid hostname port -> do + handleChangePartnerAddress mvar userid hostname port + NC.sendMessage Messages.Okay hdl + RequestSync userid -> do + handleRequestSync mvar userid + NC.sendMessage Messages.Okay hdl + SyncIncoming userid values -> do + handleSyncIncoming mvar userid values + NC.sendMessage Messages.Okay hdl + RequestClose userid -> do + handleRequestClose mvar userid + NC.sendMessage Messages.Okay hdl + _ -> do + serial <- NSerialize.serialize deserialmessages + Config.traceIO $ "Error unsupported networkmessage: "++ serial + NC.sendMessage Messages.Okay hdl + + +{- + + -- In the nothing case we shoud wait a few seconds for other messages to resolve the issue acceptClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> IO () acceptClient mvar clientlist clientsocket = do @@ -107,6 +157,9 @@ acceptClient mvar clientlist clientsocket = do NC.sendMessage Messages.Okay hdl hClose hdl + +-} + checkRedirectRequest :: Map.Map String (NetworkConnection Value) -> String -> IO Bool checkRedirectRequest ncmap userid = do case Map.lookup userid ncmap of From 51d985fbdd83045940b463c8773e46f141b6cb92 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 20 Dec 2022 20:18:23 +0100 Subject: [PATCH 071/229] Minor code cleanup --- src/Networking/Client.hs | 77 ++++++++++++++++------------------------ src/Networking/Common.hs | 4 +-- src/Networking/Server.hs | 55 +--------------------------- 3 files changed, 34 insertions(+), 102 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 0e717eb..37679cd 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -79,7 +79,7 @@ tryToSend networkconnection hostname port val valcleaned = do case mbyresponse of Just response -> case response of Okay -> Config.traceIO "Message okay" - Redirect host port -> do + Redirect host port -> do Config.traceIO "Communication partner changed address, resending" NCon.changePartnerAddress networkconnection host port tryToSend networkconnection host port val valcleaned @@ -113,14 +113,14 @@ tryToSendNetworkMessage networkconnection hostname port message = do connect clientsocket $ addrAddress $ head addrInfo handle <- NC.getHandle clientsocket NC.sendMessage message handle - + Config.traceIO "Waiting for response" mbyresponse <- recieveResponse handle hClose handle case mbyresponse of Just response -> case response of Okay -> Config.traceIO "Message okay" - Redirect host port -> do + Redirect host port -> do Config.traceIO "Communication partner changed address, resending" NCon.changePartnerAddress networkconnection host port tryToSendNetworkMessage networkconnection host port message @@ -132,31 +132,21 @@ printConErr hostname port err = Config.traceIO $ "Communication Partner " ++ hos initialConnect :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> Syntax.Type -> IO Value initialConnect mvar hostname port ownport syntype= do - {- - let hints = defaultHints { - addrFlags = [] - , addrSocketType = Stream - } - addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port - clientsocket <- NC.openSocketNC $ head addrInfo - connect clientsocket $ addrAddress $ head addrInfo - handle <- NC.getHandle clientsocket - -} handle <- getClientHandle hostname port ownuserid <- UserID.newRandomUserID Config.traceIO "Client connected: Introducing" NC.sendMessage (Messages.IntroduceClient ownuserid ownport syntype) handle introductionanswer <- waitForServerIntroduction handle Config.traceIO "Finished Handshake" - + msgserial <- NSerialize.serialize $ Messages.IntroduceClient ownuserid ownport syntype Config.traceNetIO $ "Sending message as: " ++ ownuserid ++ " to: " ++ introductionanswer Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port Config.traceNetIO $ " Message: " ++ msgserial hClose handle - + newConnection <- newNetworkConnection introductionanswer ownuserid hostname port - networkconnectionmap <- MVar.takeMVar mvar + networkconnectionmap <- MVar.takeMVar mvar let newNetworkconnectionmap = Map.insert introductionanswer newConnection networkconnectionmap MVar.putMVar mvar newNetworkconnectionmap used <- MVar.newEmptyMVar @@ -168,7 +158,7 @@ initialConnect mvar hostname port ownport syntype= do sendVChanMessages :: String -> String -> Value -> IO () sendVChanMessages newhost newport input = case input of VSend v -> sendVChanMessages newhost newport v - VPair v1 v2 -> do + VPair v1 v2 -> do sendVChanMessages newhost newport v1 sendVChanMessages newhost newport v2 VFunc penv a b -> sendVChanMessagesPEnv newhost newport penv @@ -176,7 +166,7 @@ sendVChanMessages newhost newport input = case input of VFuncCast v a b -> sendVChanMessages newhost newport v VRec penv a b c d -> sendVChanMessagesPEnv newhost newport penv VNewNatRec penv a b c d e f g -> sendVChanMessagesPEnv newhost newport penv - VChan nc _ _-> do + VChan nc _ _-> do sendNetworkMessage nc (Messages.ChangePartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID nc) newhost newport) _ <- MVar.takeMVar $ ncConnectionState nc Config.traceNetIO $ "Set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport @@ -185,7 +175,7 @@ sendVChanMessages newhost newport input = case input of where sendVChanMessagesPEnv :: String -> String -> [(String, Value)] -> IO () sendVChanMessagesPEnv _ _ [] = return () - sendVChanMessagesPEnv newhost newport (x:xs) = do + sendVChanMessagesPEnv newhost newport (x:xs) = do sendVChanMessages newhost newport $ snd x sendVChanMessagesPEnv newhost newport xs @@ -197,31 +187,28 @@ closeConnection con = do NCon.Connected hostname port -> do connectionError <- MVar.newEmptyMVar MVar.putMVar connectionError False - catch ( tryToSendNetworkMessage con hostname port (RequestClose $ Data.Maybe.fromMaybe "" $ ncOwnUserID con) ) (\exception -> do - printConErr hostname port exception + catch ( tryToSendNetworkMessage con hostname port (RequestClose $ Data.Maybe.fromMaybe "" $ ncOwnUserID con) ) (\exception -> do + printConErr hostname port exception _ <- MVar.takeMVar connectionError -- If we cannot communicate with them just close the connection MVar.putMVar connectionError True ) errorOccured <- MVar.readMVar connectionError if errorOccured then return () else do shouldClose <- MVar.readMVar $ ncRecievedRequestClose con - if shouldClose then do + if shouldClose then do Config.traceIO "Closing handshake completed" - return () + return () else do threadDelay 1000000 closeConnection con NCon.Disconnected -> Config.traceIO "Error when sending message: This channel is disconnected" NCon.Emulated -> pure () + recieveResponse :: Handle -> IO (Maybe Responses) recieveResponse handle = do - message <- hGetLine handle - case VT.runAlex message VG.parseResponses of - Left err -> do - Config.traceIO $ "Error during recieving a networkmessage: "++err - return Nothing - Right deserialmessage -> return $ Just deserialmessage + NC.recieveMessage handle VG.parseResponses (\_ -> return Nothing) (\_ des -> return $ Just des) + -- This waits until the handle is established @@ -231,7 +218,7 @@ getClientHandle hostname port = do let hints = defaultHints { addrFlags = [] , addrSocketType = Stream - } + } addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port clientsocket <- NC.openSocketNC $ head addrInfo connect clientsocket $ addrAddress $ head addrInfo @@ -240,54 +227,52 @@ getClientHandle hostname port = do expredirect :: String -> String -> IOException -> IO Handle expredirect hostname port e = do threadDelay 1000000 - getClientHandle hostname port + getClientHandle hostname port replaceVChan :: Value -> IO Value replaceVChan input = case input of VSend v -> do nv <- replaceVChan v return $ VSend nv - VPair v1 v2 -> do + VPair v1 v2 -> do nv1 <- replaceVChan v1 nv2 <- replaceVChan v2 return $ VPair nv1 nv2 VFunc penv a b -> do newpenv <- replaceVChanPEnv penv return $ VFunc newpenv a b - VDynCast v g -> do + VDynCast v g -> do nv <- replaceVChan v return $ VDynCast nv g - VFuncCast v a b -> do + VFuncCast v a b -> do nv <- replaceVChan v return $ VFuncCast nv a b - VRec penv a b c d -> do + VRec penv a b c d -> do newpenv <- replaceVChanPEnv penv return $ VRec newpenv a b c d - VNewNatRec penv a b c d e f g -> do + VNewNatRec penv a b c d e f g -> do newpenv <- replaceVChanPEnv penv return $ VNewNatRec newpenv a b c d e f g - VChan nc _ _-> do + VChan nc _ _-> do (r, rl, w, wl, pid, oid, h, p) <- serializeNetworkConnection nc return $ VChanSerial (r, rl) (w, wl) pid oid (h, p) _ -> return input where replaceVChanPEnv :: [(String, Value)] -> IO [(String, Value)] replaceVChanPEnv [] = return [] - replaceVChanPEnv (x:xs) = do + replaceVChanPEnv (x:xs) = do newval <- replaceVChan $ snd x rest <- replaceVChanPEnv xs return $ (fst x, newval):rest + waitForServerIntroduction :: Handle -> IO String waitForServerIntroduction handle = do - message <- hGetLine handle - case VT.runAlex message VG.parseResponses of - Left err -> do - Config.traceIO $ "Error during server introduction: "++err - throw $ NoIntroductionException message - Right deserial -> case deserial of + NC.recieveMessage handle VG.parseResponses (throw . NoIntroductionException) deserHandler + where + deserHandler message deserial = case deserial of OkayIntroduce partner -> do return partner - _ -> do + _ -> do Config.traceIO $ "Error during server introduction, wrong message: "++ message - throw $ NoIntroductionException message \ No newline at end of file + throw $ NoIntroductionException message diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index b970485..25e7ff0 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -22,13 +22,13 @@ getHandle socket = do return hdl -- recieveMessage :: Handle -> IO (Maybe a) -recieveMessage :: Handle -> VT.Alex t -> b -> (String -> t -> IO b) -> IO b +recieveMessage :: Handle -> VT.Alex t -> (String -> IO b) -> (String -> t -> IO b) -> IO b recieveMessage handle grammar fallbackResponse messageHandler = do message <- hGetLine handle case VT.runAlex message grammar of Left err -> do Config.traceIO $ "Error during recieving a networkmessage: "++err - return fallbackResponse + fallbackResponse message Right deserialmessage -> messageHandler message deserialmessage openSocketNC :: AddrInfo -> IO Socket diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index be048c7..128ade6 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -64,7 +64,7 @@ acceptClients mvar clientlist socket = do acceptClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> IO () acceptClient mvar clientlist clientsocket = do hdl <- NC.getHandle $ fst clientsocket - NC.recieveMessage hdl VG.parseMessages () $ handleClient mvar clientlist clientsocket hdl + NC.recieveMessage hdl VG.parseMessages (\_ -> return ()) $ handleClient mvar clientlist clientsocket hdl hClose hdl @@ -107,59 +107,6 @@ handleClient mvar clientlist clientsocket hdl message deserialmessages = do NC.sendMessage Messages.Okay hdl -{- - - --- In the nothing case we shoud wait a few seconds for other messages to resolve the issue -acceptClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> IO () -acceptClient mvar clientlist clientsocket = do - hdl <- NC.getHandle $ fst clientsocket - message <- hGetLine hdl - -- Config.traceNetIO $ "Recieved message:" ++ message - case VT.runAlex message VG.parseMessages of - -- case VT.runAlex message VG.parseValues of - Left err -> Config.traceIO $ "Error during recieving a networkmessage: "++err - Right deserialmessages -> do - let userid = getUserID deserialmessages - netcon <- MVar.takeMVar mvar - redirectRequest <- checkRedirectRequest netcon userid - MVar.putMVar mvar netcon - case Map.lookup userid netcon of - Just networkcon -> do - Config.traceNetIO $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) - Nothing -> do - Config.traceNetIO "Recieved message from unknown connection!" - Config.traceNetIO $ " Message: " ++ message - - if redirectRequest then sendRedirect hdl netcon userid else do - case deserialmessages of - NewValue userid val -> do - handleNewValue mvar userid val - NC.sendMessage Messages.Okay hdl - IntroduceClient userid clientport syntype-> do - handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype - -- Okay message is handled in handle introduce - ChangePartnerAddress userid hostname port -> do - handleChangePartnerAddress mvar userid hostname port - NC.sendMessage Messages.Okay hdl - RequestSync userid -> do - handleRequestSync mvar userid - NC.sendMessage Messages.Okay hdl - SyncIncoming userid values -> do - handleSyncIncoming mvar userid values - NC.sendMessage Messages.Okay hdl - RequestClose userid -> do - handleRequestClose mvar userid - NC.sendMessage Messages.Okay hdl - _ -> do - serial <- NSerialize.serialize deserialmessages - Config.traceIO $ "Error unsupported networkmessage: "++ serial - NC.sendMessage Messages.Okay hdl - hClose hdl - - --} - checkRedirectRequest :: Map.Map String (NetworkConnection Value) -> String -> IO Bool checkRedirectRequest ncmap userid = do case Map.lookup userid ncmap of From 78bd52e9a2f6ae965ce2943c8274941a594ec102 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Fri, 23 Dec 2022 14:40:47 +0100 Subject: [PATCH 072/229] Removed unnecessary code --- src/Interpreter.hs | 2 +- src/Networking/Client.hs | 52 ++++++------------------------------- src/Networking/Serialize.hs | 3 --- src/Networking/Server.hs | 8 ------ 4 files changed, 9 insertions(+), 56 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index dda0de6..3af8479 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -294,7 +294,7 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) interpretApp _ (VSend v@(VChan cc _ usedmvar)) w = do used <- liftIO $ MVar.readMVar usedmvar if used then throw $ VChanIsUsedException $ show v else do - liftIO $ NClient.sendMessage cc w + liftIO $ NClient.sendValue cc w -- Disable old VChan newV <- liftIO $ disableOldVChan v diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 37679cd..2184edd 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -40,53 +40,23 @@ instance Show ClientException where instance Exception ClientException -sendMessage :: NetworkConnection Value -> Value -> IO () -sendMessage networkconnection val = do +sendValue :: NetworkConnection Value -> Value -> IO () +sendValue networkconnection val = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port -> do valcleaned <- replaceVChan val DC.writeMessage (ncWrite networkconnection) valcleaned - catch (tryToSend networkconnection hostname port val valcleaned) $ printConErr hostname port + -- catch (tryToSend networkconnection hostname port val valcleaned) $ printConErr hostname port + catch (do + tryToSendNetworkMessage networkconnection hostname port (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) valcleaned) + sendVChanMessages hostname port val + disableVChans val + ) $ printConErr hostname port NCon.Disconnected -> Config.traceIO "Error when sending message: This channel is disconnected" NCon.Emulated -> DC.writeMessage (ncWrite networkconnection) val -- MVar.putMVar (ncConnectionState networkconnection) connectionstate - -tryToSend :: NetworkConnection Value -> String -> String -> Value -> Value -> IO () -tryToSend networkconnection hostname port val valcleaned = do - serializedValue <- NSerialize.serialize valcleaned - Config.traceNetIO $ "Sending message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection) ++ " to: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkconnection) - Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port - Config.traceNetIO $ " Message: " ++ serializedValue - let hints = defaultHints { - addrFlags = [] - , addrSocketType = Stream - } - Config.traceIO $ "Trying to connect to: " ++ hostname ++":"++port - addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port - clientsocket <- NC.openSocketNC $ head addrInfo - connect clientsocket $ addrAddress $ head addrInfo - handle <- NC.getHandle clientsocket - - NC.sendMessage (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) valcleaned) handle - sendVChanMessages hostname port val -- This sends a ChangeNetworkPartner Message if appropriate - - disableVChans val -- Disables all sent VChans for the sending party - Config.traceIO "Waiting for response" - mbyresponse <- recieveResponse handle - hClose handle - case mbyresponse of - Just response -> case response of - Okay -> Config.traceIO "Message okay" - Redirect host port -> do - Config.traceIO "Communication partner changed address, resending" - NCon.changePartnerAddress networkconnection host port - tryToSend networkconnection host port val valcleaned - Nothing -> Config.traceIO "Error when recieving response" - - - sendNetworkMessage :: NetworkConnection Value -> Messages -> IO () sendNetworkMessage networkconnection message = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection @@ -153,8 +123,6 @@ initialConnect mvar hostname port ownport syntype= do MVar.putMVar used False return $ VChan newConnection mvar used - - sendVChanMessages :: String -> String -> Value -> IO () sendVChanMessages newhost newport input = case input of VSend v -> sendVChanMessages newhost newport v @@ -179,7 +147,6 @@ sendVChanMessages newhost newport input = case input of sendVChanMessages newhost newport $ snd x sendVChanMessagesPEnv newhost newport xs - closeConnection :: NetworkConnection Value -> IO () closeConnection con = do connectionstate <- MVar.readMVar $ ncConnectionState con @@ -209,8 +176,6 @@ recieveResponse :: Handle -> IO (Maybe Responses) recieveResponse handle = do NC.recieveMessage handle VG.parseResponses (\_ -> return Nothing) (\_ des -> return $ Just des) - - -- This waits until the handle is established getClientHandle :: String -> String -> IO Handle getClientHandle hostname port = do @@ -265,7 +230,6 @@ replaceVChan input = case input of rest <- replaceVChanPEnv xs return $ (fst x, newval):rest - waitForServerIntroduction :: Handle -> IO String waitForServerIntroduction handle = do NC.recieveMessage handle VG.parseResponses (throw . NoIntroductionException) deserHandler diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index 6df09db..7602c5f 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -55,7 +55,6 @@ instance Serializable (NCon.NetworkConnection Value) where (readList, readUnread) <- DC.serializeConnection $ NCon.ncRead con (writeList, writeUnread) <- DC.serializeConnection $ NCon.ncWrite con - serializeLabeledEntryMulti "SNetworkConnection" (NCon.ncRead con) $ sNext (NCon.ncWrite con) $ sNext (Data.Maybe.fromMaybe "" $ NCon.ncPartnerUserID con) $ sNext (Data.Maybe.fromMaybe "" $ NCon.ncOwnUserID con) $ sLast constate instance Serializable (NCon.DirectionalConnection Value) where @@ -64,13 +63,11 @@ instance Serializable (NCon.DirectionalConnection Value) where serializeLabeledEntryMulti "SDirectionalConnection" msg $ sLast msgUnread - instance Serializable NCon.ConnectionState where serialize = \case NCon.Connected hostname port -> serializeLabeledEntryMulti "SConnected" hostname $ sLast port _ -> throw $ UnserializableException "VChan can only be serialized when in Connected mode" - instance Serializable Value where serialize = \case VUnit -> return "VUnit" diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 128ade6..6b4b4be 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -59,7 +59,6 @@ acceptClients mvar clientlist socket = do forkIO $ acceptClient mvar clientlist clientsocket acceptClients mvar clientlist socket - -- In the nothing case we shoud wait a few seconds for other messages to resolve the issue acceptClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> IO () acceptClient mvar clientlist clientsocket = do @@ -67,7 +66,6 @@ acceptClient mvar clientlist clientsocket = do NC.recieveMessage hdl VG.parseMessages (\_ -> return ()) $ handleClient mvar clientlist clientsocket hdl hClose hdl - handleClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> Messages -> IO () handleClient mvar clientlist clientsocket hdl message deserialmessages = do let userid = getUserID deserialmessages @@ -106,7 +104,6 @@ handleClient mvar clientlist clientsocket hdl message deserialmessages = do Config.traceIO $ "Error unsupported networkmessage: "++ serial NC.sendMessage Messages.Okay hdl - checkRedirectRequest :: Map.Map String (NetworkConnection Value) -> String -> IO Bool checkRedirectRequest ncmap userid = do case Map.lookup userid ncmap of @@ -118,7 +115,6 @@ checkRedirectRequest ncmap userid = do RedirectRequest _ _ -> return True _ -> return False - sendRedirect :: Handle -> Map.Map String (NetworkConnection Value) -> String -> IO () sendRedirect handle ncmap userid = do case Map.lookup userid ncmap of @@ -129,8 +125,6 @@ sendRedirect handle ncmap userid = do RedirectRequest host port -> NC.sendMessage (Messages.Redirect host port) handle _ -> return () - - handleNewValue :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> Value -> IO () handleNewValue mvar userid val = do networkconnectionmap <- MVar.takeMVar mvar @@ -205,7 +199,6 @@ handleRequestClose mvar userid = do Nothing -> return () MVar.putMVar mvar networkconnectionmap - hostaddressTypeToString :: HostAddress -> String hostaddressTypeToString hostaddress = do let (a, b, c, d) = hostAddressToTuple hostaddress @@ -235,7 +228,6 @@ findFittingClient clientlist desiredType = do threadDelay 10000 -- Sleep for 10 ms to not hammer the CPU findFittingClient clientlist desiredType - replaceVChanSerial :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> Value -> IO Value replaceVChanSerial mvar input = case input of VSend v -> do From 5cbad69c946e680d018334f2a8de38f717c78ff0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Fri, 23 Dec 2022 15:10:20 +0100 Subject: [PATCH 073/229] Clean up --- dev-examples/add/client-old.ldgvnw | 19 ---- dev-examples/add/client.ldgvnw | 2 + dev-examples/add/server copy.ldgvnw | 19 ---- dev-examples/add/server.ldgvnw | 3 + dev-examples/add/test.ldgvnw | 22 ----- dev-examples/handoff2/notes | 1 - dev-examples/handoff2/problem/client | 83 ------------------ dev-examples/handoff2/problem/handoff | 61 ------------- dev-examples/handoff2/problem/server | 120 -------------------------- dev-examples/handoff2/serverproblem | 0 src/Networking/Common.hs | 1 - 11 files changed, 5 insertions(+), 326 deletions(-) delete mode 100644 dev-examples/add/client-old.ldgvnw delete mode 100644 dev-examples/add/server copy.ldgvnw delete mode 100644 dev-examples/add/test.ldgvnw delete mode 100644 dev-examples/handoff2/notes delete mode 100644 dev-examples/handoff2/problem/client delete mode 100644 dev-examples/handoff2/problem/handoff delete mode 100644 dev-examples/handoff2/problem/server delete mode 100644 dev-examples/handoff2/serverproblem diff --git a/dev-examples/add/client-old.ldgvnw b/dev-examples/add/client-old.ldgvnw deleted file mode 100644 index 7996182..0000000 --- a/dev-examples/add/client-old.ldgvnw +++ /dev/null @@ -1,19 +0,0 @@ --- Simple example of Label-Dependent Session Types --- Interprets addition of two numbers - -type SendInt : ! ~ssn = !Int. !Int. Unit - -val send2 (c: SendInt) = - let x = ((send c) 1) in - let y = ((send x) 42) in - () - -val add2 (c1: dualof SendInt) = - let = recv c1 in - let = recv c2 in - (m + n) - -val main : Unit -val main = - let con = (connect "127.0.0.1" 4242 SendInt) in -- This cannot be localhost, since this might break on containerized images - send2 con diff --git a/dev-examples/add/client.ldgvnw b/dev-examples/add/client.ldgvnw index 509798d..3f17302 100644 --- a/dev-examples/add/client.ldgvnw +++ b/dev-examples/add/client.ldgvnw @@ -6,11 +6,13 @@ type SendInt : ! ~ssn = !Int. !Int. Unit val send2 (c: SendInt) = let x = ((send c) 1) in let y = ((send x) 42) in + let z = end y in () val add2 (c1: dualof SendInt) = let = recv c1 in let = recv c2 in + let c4 = end c3 in (m + n) val main : Unit diff --git a/dev-examples/add/server copy.ldgvnw b/dev-examples/add/server copy.ldgvnw deleted file mode 100644 index b76baaa..0000000 --- a/dev-examples/add/server copy.ldgvnw +++ /dev/null @@ -1,19 +0,0 @@ --- Simple example of Label-Dependent Session Types --- Interprets addition of two numbers - -type SendInt : ! ~ssn = !Int. !Int. Unit - -val send2 (c: SendInt) = - let x = ((send c) 1) in - let y = ((send x) 42) in - () - -val add2 (c1: dualof SendInt) = - let = recv c1 in - let = recv c2 in - (m + n) - -val main : Int -val main = - let con = (create 4242 (dualof SendInt)) in - add2 con diff --git a/dev-examples/add/server.ldgvnw b/dev-examples/add/server.ldgvnw index e9f99db..2410a32 100644 --- a/dev-examples/add/server.ldgvnw +++ b/dev-examples/add/server.ldgvnw @@ -6,13 +6,16 @@ type SendInt : ! ~ssn = !Int. !Int. Unit val send2 (c: SendInt) = let x = ((send c) 1) in let y = ((send x) 42) in + let z = end y in () val add2 (c1: dualof SendInt) = let = recv c1 in let = recv c2 in + let c4 = end c3 in (m + n) + val main : Int val main = let sock = (create 4242) in diff --git a/dev-examples/add/test.ldgvnw b/dev-examples/add/test.ldgvnw deleted file mode 100644 index c77c93a..0000000 --- a/dev-examples/add/test.ldgvnw +++ /dev/null @@ -1,22 +0,0 @@ --- Simple example of Label-Dependent Session Types --- Interprets addition of two numbers - -type SendInt : ! ~ssn = !Int. !Int. Unit - -val send2 (c: SendInt) (d: SendInt) = - let x = ((send c) 1) in - let z = ((send d) 1) in - let y = ((send x) 42) in - let w = ((send z) 42) in - () - -val add2 (c1: dualof SendInt) = - let = recv c1 in - let = recv c2 in - (m + n) - -val main : Unit -val main = - let con = (connect "127.0.0.1" 4242 SendInt) in -- This cannot be localhost, since this might break on containerized images - let co2 = (connect "127.0.0.1" 4242 SendInt) in -- This cannot be localhost, since this might break on containerized images - send2 con co2 diff --git a/dev-examples/handoff2/notes b/dev-examples/handoff2/notes deleted file mode 100644 index 83206c0..0000000 --- a/dev-examples/handoff2/notes +++ /dev/null @@ -1 +0,0 @@ -There is a race condition when the client and server is already offline when the handoff wants data \ No newline at end of file diff --git a/dev-examples/handoff2/problem/client b/dev-examples/handoff2/problem/client deleted file mode 100644 index 343fa78..0000000 --- a/dev-examples/handoff2/problem/client +++ /dev/null @@ -1,83 +0,0 @@ -Invoking interpretation on 𝜆 (c : SendInt) let x = send c 1 in let y = send x 42 in let z = end y in () -Invoking interpretation on 𝜆 (c1 : ~SendInt) let = recv c1 in let = recv c2 in let c4 = end c3 in m + n -Invoking interpretation on let sock = create 4444 in let con = connect sock SendInt 127.0.0.1 4242 in send2 con -Invoking interpretation on create 4444 -Creating socket! -Invoking interpretation on 4444 -Leaving interpretation of 4444 with value VInt 4444 -Socket created -Invoking interpretation on let con = connect sock SendInt 127.0.0.1 4242 in send2 con -Invoking interpretation on connect sock SendInt 127.0.0.1 4242 -Client trying to connect -Invoking interpretation on sock -Leaving interpretation of create 4444 with value VServerSocket -Leaving interpretation of sock with value VServerSocket -Invoking interpretation on 127.0.0.1 -Leaving interpretation of 127.0.0.1 with value VString ""127.0.0.1"" -Invoking interpretation on 4242 -Leaving interpretation of 4242 with value VInt 4242 -Waiting for clients -Client connected: Introducing -Sending message:NIntroduceClient (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") (String:"4444") (TName (Bool:False) (String:"SendInt")) -Finished Handshake -Invoking interpretation on send2 con -Arguments for (send2) are (con) -Invoking interpretation on send2 -Invoking interpretation on con -Leaving interpretation of 𝜆 (c : SendInt) let x = send c 1 in let y = send x 42 in let z = end y in () with value VFunc "c" Let "x" (App (Send (Var "c")) (Lit (LNat 1))) (Let "y" (App (Send (Var "x")) (Lit (LNat 42))) (Let "z" (End (Var "y")) (Lit LUnit))) -Leaving interpretation of send2 with value VFunc "c" Let "x" (App (Send (Var "c")) (Lit (LNat 1))) (Let "y" (App (Send (Var "x")) (Lit (LNat 42))) (Let "z" (End (Var "y")) (Lit LUnit))) -Invoking interpretation on let x = send c 1 in let y = send x 42 in let z = end y in () -Invoking interpretation on send c 1 -Arguments for (send c) are (1) -Invoking interpretation on send c -Invoking interpretation on c -Invoking interpretation on 1 -Leaving interpretation of connect sock SendInt 127.0.0.1 4242 with value VChan -Leaving interpretation of con with value VChan -Leaving interpretation of c with value VChan -Leaving interpretation of send c with value VSend (VChan) -Trying to connect to: 127.0.0.1:4242 -Leaving interpretation of 1 with value VInt 1 -Sending message:NNewValue (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") (VInt (Int:1)) -Waiting for response -Message okay -Invoking interpretation on let y = send x 42 in let z = end y in () -Invoking interpretation on send x 42 -Arguments for (send x) are (42) -Invoking interpretation on send x -Invoking interpretation on x -Invoking interpretation on 42 -Leaving interpretation of send c 1 with value VChan -Leaving interpretation of x with value VChan -Leaving interpretation of send x with value VSend (VChan) -Trying to connect to: 127.0.0.1:4242 -Leaving interpretation of 42 with value VInt 42 -Sending message:NNewValue (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") (VInt (Int:42)) -Waiting for response -Accepted new client -Waiting for clients -Recieved message:NChangePartnerAddress (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") (String:"127.0.0.1") (String:"4343") -Trying to connect to: 127.0.0.1:4343 -Sending message:NRequestSync (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") -Waiting for response -Message okay -Invoking interpretation on let z = end y in () -Invoking interpretation on end y -Invoking interpretation on y -Leaving interpretation of send x 42 with value VChan -Leaving interpretation of y with value VChan -Trying to connect to: 127.0.0.1:4242 -Sending message:NRequestClose (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") -Waiting for response -Message okay -Message okay -Trying to connect to: 127.0.0.1:4343 -Sending message:NSyncIncoming (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") (SValuesArray [VInt (Int:1), VInt (Int:42)]) -Waiting for response -Message okay -Sending message:NOkay -Trying to connect to: 127.0.0.1:4242 -Sending message:NRequestClose (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") -Waiting for response -Message okay -^C diff --git a/dev-examples/handoff2/problem/handoff b/dev-examples/handoff2/problem/handoff deleted file mode 100644 index 7af6bb3..0000000 --- a/dev-examples/handoff2/problem/handoff +++ /dev/null @@ -1,61 +0,0 @@ -Leaving tySynth with let = recv con in let = recv oneint in let c4 = end c2 in let c5 = end c3 in result : Int -| [(con, (0, ~SendSendOneInt)), (sock, (_, ★)), (main, (_, Int))] -Leaving tySynth with let con = connect sock ~SendSendOneInt 127.0.0.1 4242 in let = recv con in let = recv oneint in let c4 = end c2 in let c5 = end c3 in result : Int -| [(sock, (_, ★)), (main, (_, Int))] -Leaving tySynth with let sock = create 4343 in let con = connect sock ~SendSendOneInt 127.0.0.1 4242 in let = recv con in let = recv oneint in let c4 = end c2 in let c5 = end c3 in result : Int -| [(main, (_, Int))] -subtype: Entering [(main, (_, Int))] (Int) (Int) -Success: ([(main, (_, Int))], []) -Invoking interpretation on let sock = create 4343 in let con = connect sock ~SendSendOneInt 127.0.0.1 4242 in let = recv con in let = recv oneint in let c4 = end c2 in let c5 = end c3 in result -Invoking interpretation on create 4343 -Creating socket! -Invoking interpretation on 4343 -Leaving interpretation of 4343 with value VInt 4343 -Socket created -Waiting for clients -Invoking interpretation on let con = connect sock ~SendSendOneInt 127.0.0.1 4242 in let = recv con in let = recv oneint in let c4 = end c2 in let c5 = end c3 in result -Invoking interpretation on connect sock ~SendSendOneInt 127.0.0.1 4242 -Client trying to connect -Invoking interpretation on sock -Leaving interpretation of create 4343 with value VServerSocket -Leaving interpretation of sock with value VServerSocket -Invoking interpretation on 127.0.0.1 -Leaving interpretation of 127.0.0.1 with value VString ""127.0.0.1"" -Invoking interpretation on 4242 -Leaving interpretation of 4242 with value VInt 4242 -Client connected: Introducing -Sending message:NIntroduceClient (String:"jA4YaqSHz3CbIwZiw5UWFxeNYM4ibINapqukOxjg9bV07B94E3q19QDgwgThmxK7cJy7rQCmR9viuYmcYm5NPEWrJInZPqV2y5nTOInyORhyqjcatRD8C8JASy5xu93c") (String:"4343") (TName (Bool:True) (String:"SendSendOneInt")) -Finished Handshake -Invoking interpretation on let = recv con in let = recv oneint in let c4 = end c2 in let c5 = end c3 in result -Invoking interpretation on recv con -Invoking interpretation on con -Leaving interpretation of connect sock ~SendSendOneInt 127.0.0.1 4242 with value VChan -Leaving interpretation of con with value VChan -Accepted new client -Waiting for clients -Accepted new client -Waiting for clients -Recieved message:NRequestSync (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") -Sending message:NOkay -Recieved message:NNewValue (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") (((String:"127.0.0.1") (String:"4444")))) -Sending message:NOkay -Read VChan from Chan, over expression Var "con" -Leaving interpretation of recv con with value VPair -Invoking interpretation on let = recv oneint in let c4 = end c2 in let c5 = end c3 in result -Invoking interpretation on recv oneint -Invoking interpretation on oneint -Leaving interpretation of oneint with value VChan -Accepted new client -Waiting for clients -Recieved message:NSyncIncoming (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") (SValuesArray [VInt (Int:1), VInt (Int:42)]) -Sending message:NOkay -Accepted new client -Waiting for clients -Recieved message:NRequestClose (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") -Sending message:NOkay -Accepted new client -Waiting for clients -Recieved message:NRequestClose (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") -Sending message:NOkay -Accepted new client -Waiting for clients -Recieved message:NRequestClose (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") -Sending message:NOkay -^C diff --git a/dev-examples/handoff2/problem/server b/dev-examples/handoff2/problem/server deleted file mode 100644 index 9d304f1..0000000 --- a/dev-examples/handoff2/problem/server +++ /dev/null @@ -1,120 +0,0 @@ -Invoking interpretation on 𝜆 (c : SendInt) let x = send c 1 in let y = send x 42 in let z = end y in () -Invoking interpretation on 𝜆 (c1 : ~SendInt) 𝜆 (c3 : SendSendOneInt) let = recv c1 in let y = send c3 c2 in let z = end y in m -Invoking interpretation on let sock = create 4242 in let con1 = accept sock ~SendInt in let con2 = accept sock SendSendOneInt in add2 con1 con2 -Invoking interpretation on create 4242 -Creating socket! -Invoking interpretation on 4242 -Leaving interpretation of 4242 with value VInt 4242 -Socket created -Waiting for clients -Invoking interpretation on let con1 = accept sock ~SendInt in let con2 = accept sock SendSendOneInt in add2 con1 con2 -Invoking interpretation on accept sock ~SendInt -Accepting new client! -Invoking interpretation on sock -Leaving interpretation of create 4242 with value VServerSocket -Leaving interpretation of sock with value VServerSocket -Searching for correct communicationpartner -Accepted new client -Waiting for clients -Recieved message:NIntroduceClient (String:"jA4YaqSHz3CbIwZiw5UWFxeNYM4ibINapqukOxjg9bV07B94E3q19QDgwgThmxK7cJy7rQCmR9viuYmcYm5NPEWrJInZPqV2y5nTOInyORhyqjcatRD8C8JASy5xu93c") (String:"4343") (TName (Bool:True) (String:"SendSendOneInt")) -Sending message:NIntroduce (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") -Sending message:NOkay -Accepted new client -Waiting for clients -Recieved message:NIntroduceClient (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") (String:"4444") (TName (Bool:False) (String:"SendInt")) -Sending message:NIntroduce (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") -Sending message:NOkay -Client accepted -Client successfully accepted! -Invoking interpretation on let con2 = accept sock SendSendOneInt in add2 con1 con2 -Invoking interpretation on accept sock SendSendOneInt -Accepting new client! -Invoking interpretation on sock -Leaving interpretation of sock with value VServerSocket -Searching for correct communicationpartner -Client accepted -Client successfully accepted! -Invoking interpretation on add2 con1 con2 -Arguments for (add2 con1) are (con2) -Invoking interpretation on add2 con1 -Arguments for (add2) are (con1) -Invoking interpretation on add2 -Invoking interpretation on con1 -Leaving interpretation of 𝜆 (c1 : ~SendInt) 𝜆 (c3 : SendSendOneInt) let = recv c1 in let y = send c3 c2 in let z = end y in m with value VFunc "c1" Lam MMany "c3" (TName False "SendSendOneInt") (LetPair "m" "c2" (Recv (Var "c1")) (Let "y" (App (Send (Var "c3")) (Var "c2")) (Let "z" (End (Var "y")) (Var "m")))) -Leaving interpretation of add2 with value VFunc "c1" Lam MMany "c3" (TName False "SendSendOneInt") (LetPair "m" "c2" (Recv (Var "c1")) (Let "y" (App (Send (Var "c3")) (Var "c2")) (Let "z" (End (Var "y")) (Var "m")))) -Invoking interpretation on 𝜆 (c3 : SendSendOneInt) let = recv c1 in let y = send c3 c2 in let z = end y in m -Invoking interpretation on con2 -Leaving interpretation of 𝜆 (c3 : SendSendOneInt) let = recv c1 in let y = send c3 c2 in let z = end y in m with value VFunc "c3" LetPair "m" "c2" (Recv (Var "c1")) (Let "y" (App (Send (Var "c3")) (Var "c2")) (Let "z" (End (Var "y")) (Var "m"))) -Leaving interpretation of add2 con1 with value VFunc "c3" LetPair "m" "c2" (Recv (Var "c1")) (Let "y" (App (Send (Var "c3")) (Var "c2")) (Let "z" (End (Var "y")) (Var "m"))) -Invoking interpretation on let = recv c1 in let y = send c3 c2 in let z = end y in m -Invoking interpretation on recv c1 -Invoking interpretation on c1 -Accepted new client -Waiting for clients -Leaving interpretation of accept sock ~SendInt with value VChan -Leaving interpretation of con1 with value VChan -Leaving interpretation of c1 with value VChan -Recieved message:NNewValue (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") (VInt (Int:1)) -Sending message:NOkay -Accepted new client -Waiting for clients -Read VInt 1 from Chan, over expression Var "c1" -Leaving interpretation of recv c1 with value VPair -Invoking interpretation on let y = send c3 c2 in let z = end y in m -Invoking interpretation on send c3 c2 -Arguments for (send c3) are (c2) -Invoking interpretation on send c3 -Invoking interpretation on c3 -Invoking interpretation on c2 -Leaving interpretation of accept sock SendSendOneInt with value VChan -Leaving interpretation of con2 with value VChan -Leaving interpretation of c3 with value VChan -Leaving interpretation of send c3 with value VSend (VChan) -Trying to connect to: 127.0.0.1:4343 -Leaving interpretation of c2 with value VChan -Sending message:NNewValue (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") (((String:"127.0.0.1") (String:"4444")))) -Trying to connect to: 127.0.0.1:4444 -Sending message:NChangePartnerAddress (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") (String:"127.0.0.1") (String:"4343") -Waiting for response -Recieved message:NNewValue (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") (VInt (Int:42)) -Sending message:NOkay -Accepted new client -Waiting for clients -Recieved message:NRequestClose (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") -Sending message:NOkay -Message okay -Waiting for response -Message okay -Invoking interpretation on let z = end y in m -Invoking interpretation on end y -Invoking interpretation on y -Leaving interpretation of send c3 c2 with value VChan -Leaving interpretation of y with value VChan -Trying to connect to: 127.0.0.1:4343 -Sending message:NRequestClose (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") -Waiting for response -Message okay -Accepted new client -Waiting for clients -Recieved message:NRequestClose (String:"eSjynyc9ADY8bYwP4oMX2lwBD54oEaWXSgCBiAsw0YD2Az8GWLiEAQSeJXx46sP5rQLDfKWTCAfDjDRJHqUtskA2NDbJrBRkT336oaYIRIbQHFpRH3gZQ1b7SGJekjnE") -Sending message:NOkay -Trying to connect to: 127.0.0.1:4343 -Sending message:NRequestClose (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") -Waiting for response -Message okay -Trying to connect to: 127.0.0.1:4343 -Sending message:NRequestClose (String:"Ftj3NjTqeEa7yqGwr07JanWWbuvXxYIphkmqhAWN43MrfU7o4Vwqsk0Eleya7mRPEjgGNrCNb89NE73IXv4zoElnIa1mV3xYl1tGCHntn1qsuN5UKlntmCSdhQ1ZEsIn") -Waiting for response -Message okay -Trying to connect to: 127.0.0.1:4343 -Communication Partner 127.0.0.1:4343not found! -Invoking interpretation on m -Leaving interpretation of m with value VInt 1 -Leaving interpretation of let z = end y in m with value VInt 1 -Leaving interpretation of let y = send c3 c2 in let z = end y in m with value VInt 1 -Leaving interpretation of let = recv c1 in let y = send c3 c2 in let z = end y in m with value VInt 1 -Leaving interpretation of add2 con1 con2 with value VInt 1 -Leaving interpretation of let con2 = accept sock SendSendOneInt in add2 con1 con2 with value VInt 1 -Leaving interpretation of let con1 = accept sock ~SendInt in let con2 = accept sock SendSendOneInt in add2 con1 con2 with value VInt 1 -Leaving interpretation of let sock = create 4242 in let con1 = accept sock ~SendInt in let con2 = accept sock SendSendOneInt in add2 con1 con2 with value VInt 1 -Result: VInt 1 diff --git a/dev-examples/handoff2/serverproblem b/dev-examples/handoff2/serverproblem deleted file mode 100644 index e69de29..0000000 diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 25e7ff0..7fd3512 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -21,7 +21,6 @@ getHandle socket = do hSetBuffering hdl NoBuffering return hdl --- recieveMessage :: Handle -> IO (Maybe a) recieveMessage :: Handle -> VT.Alex t -> (String -> IO b) -> (String -> t -> IO b) -> IO b recieveMessage handle grammar fallbackResponse messageHandler = do message <- hGetLine handle From 50b532c721ba507bbd006000d470dc4a396a2941 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sat, 24 Dec 2022 14:30:03 +0100 Subject: [PATCH 074/229] Removed the need for the create command --- dev-examples/add/client.ldgvnw | 4 +- dev-examples/add/server.ldgvnw | 4 +- dev-examples/bidirectional/client.ldgvnw | 4 +- dev-examples/bidirectional/server.ldgvnw | 4 +- .../bidirhandoff/BugsAssociatedWithThisTest | 1 + dev-examples/bidirhandoff/client.ldgvnw | 6 +- .../bidirhandoff/clienthandoff.ldgvnw | 4 +- dev-examples/bidirhandoff/server.ldgvnw | 6 +- .../bidirhandoff/serverhandoff.ldgvnw | 4 +- dev-examples/handoff/client.ldgvnw | 6 +- dev-examples/handoff/handoff.ldgvnw | 6 +- dev-examples/handoff/server.ldgvnw | 6 +- dev-examples/handoff2/client.ldgvnw | 2 +- dev-examples/handoff2/handoff.ldgvnw | 2 +- dev-examples/handoff2/server.ldgvnw | 2 +- dev-examples/simple/client.ldgvnw | 2 +- dev-examples/simple/server.ldgvnw | 2 +- src/Interpreter.hs | 101 ++++++++++-------- src/Networking/Server.hs | 19 +++- src/ProcessEnvironment.hs | 3 +- 20 files changed, 109 insertions(+), 79 deletions(-) create mode 100644 dev-examples/bidirhandoff/BugsAssociatedWithThisTest diff --git a/dev-examples/add/client.ldgvnw b/dev-examples/add/client.ldgvnw index 3f17302..6c98496 100644 --- a/dev-examples/add/client.ldgvnw +++ b/dev-examples/add/client.ldgvnw @@ -17,6 +17,6 @@ val add2 (c1: dualof SendInt) = val main : Unit val main = - let sock = (create 4343) in - let con = (connect sock SendInt "127.0.0.1" 4242 ) in -- This cannot be localhost, since this might break on containerized images + -- let sock = (create 4343) in + let con = (connect 4343 SendInt "127.0.0.1" 4242 ) in -- This cannot be localhost, since this might break on containerized images send2 con diff --git a/dev-examples/add/server.ldgvnw b/dev-examples/add/server.ldgvnw index 2410a32..66b4476 100644 --- a/dev-examples/add/server.ldgvnw +++ b/dev-examples/add/server.ldgvnw @@ -18,6 +18,6 @@ val add2 (c1: dualof SendInt) = val main : Int val main = - let sock = (create 4242) in - let con = (accept sock (dualof SendInt)) in + -- let sock = (create 4242) in + let con = (accept 4242 (dualof SendInt)) in add2 con diff --git a/dev-examples/bidirectional/client.ldgvnw b/dev-examples/bidirectional/client.ldgvnw index 98c815d..76574e4 100644 --- a/dev-examples/bidirectional/client.ldgvnw +++ b/dev-examples/bidirectional/client.ldgvnw @@ -21,6 +21,6 @@ val add2 (c1: dualof SendInt) = val main : Int val main = - let sock = (create 4343) in - let con = (connect sock SendInt "127.0.0.1" 4242 ) in -- This cannot be localhost, since this might break on containerized images + -- let sock = (create 4343) in + let con = (connect 4343 SendInt "127.0.0.1" 4242 ) in -- This cannot be localhost, since this might break on containerized images send2 con diff --git a/dev-examples/bidirectional/server.ldgvnw b/dev-examples/bidirectional/server.ldgvnw index 0c61456..0b99ba3 100644 --- a/dev-examples/bidirectional/server.ldgvnw +++ b/dev-examples/bidirectional/server.ldgvnw @@ -21,6 +21,6 @@ val add2 (c1: dualof SendInt) = val main : Int val main = - let sock = (create 4242) in - let con = (accept sock (dualof SendInt)) in + -- let sock = (create 4242) in + let con = (accept 4242 (dualof SendInt)) in add2 con diff --git a/dev-examples/bidirhandoff/BugsAssociatedWithThisTest b/dev-examples/bidirhandoff/BugsAssociatedWithThisTest new file mode 100644 index 0000000..40a0401 --- /dev/null +++ b/dev-examples/bidirhandoff/BugsAssociatedWithThisTest @@ -0,0 +1 @@ +In some cases when start order is server client clienthandoff serverhandoff communication might not end properly \ No newline at end of file diff --git a/dev-examples/bidirhandoff/client.ldgvnw b/dev-examples/bidirhandoff/client.ldgvnw index ee8969b..cf01cf3 100644 --- a/dev-examples/bidirhandoff/client.ldgvnw +++ b/dev-examples/bidirhandoff/client.ldgvnw @@ -25,11 +25,11 @@ val add2 (c1: dualof SendInt) = val main : Int val main = - let sock = (create 4343) in - let con = (connect sock SendInt "127.0.0.1" 4242 ) in -- This cannot be localhost, since this might break on containerized images + -- let sock = (create 4343) in + let con = (connect 4343 SendInt "127.0.0.1" 4242 ) in -- This cannot be localhost, since this might break on containerized images let x = ((send con) 1) in let = recv x in - let con2 = (connect sock SendSendIntClient "127.0.0.1" 4340) in + let con2 = (connect 4343 SendSendIntClient "127.0.0.1" 4340) in let con22 = ((send con2) x2) in let con23 = end con22 in (n) diff --git a/dev-examples/bidirhandoff/clienthandoff.ldgvnw b/dev-examples/bidirhandoff/clienthandoff.ldgvnw index 1ef2008..768682d 100644 --- a/dev-examples/bidirhandoff/clienthandoff.ldgvnw +++ b/dev-examples/bidirhandoff/clienthandoff.ldgvnw @@ -25,8 +25,8 @@ val add2 (c1: dualof SendInt) = val main : Int val main = - let sock = (create 4340) in - let con = (accept sock (dualof SendSendIntClient)) in -- This cannot be localhost, since this might break on containerized images + -- let sock = (create 4340) in + let con = (accept 4340 (dualof SendSendIntClient)) in -- This cannot be localhost, since this might break on containerized images let = (recv con) in let x = ((send talk) 41) in let = recv x in diff --git a/dev-examples/bidirhandoff/server.ldgvnw b/dev-examples/bidirhandoff/server.ldgvnw index 4bfc166..16158da 100644 --- a/dev-examples/bidirhandoff/server.ldgvnw +++ b/dev-examples/bidirhandoff/server.ldgvnw @@ -25,11 +25,11 @@ val add2 (c1: dualof SendInt) = val main : Int val main = - let sock = (create 4242) in - let con = (accept sock (dualof SendInt)) in + -- let sock = (create 4242) in + let con = (accept 4242 (dualof SendInt)) in let = recv con in let c22 = (send c2) 1300 in - let con2 = (accept sock (SendSendIntServer)) in + let con2 = (accept 4242 (SendSendIntServer)) in let con3 = ((send con2) c22) in let con4 = end con3 in (m) diff --git a/dev-examples/bidirhandoff/serverhandoff.ldgvnw b/dev-examples/bidirhandoff/serverhandoff.ldgvnw index cc1f1d7..9fc0674 100644 --- a/dev-examples/bidirhandoff/serverhandoff.ldgvnw +++ b/dev-examples/bidirhandoff/serverhandoff.ldgvnw @@ -25,8 +25,8 @@ val add2 (c1: dualof SendInt) = val main : Int val main = - let sock = (create 4240) in - let con = (connect sock (dualof SendSendIntServer) "127.0.0.1" 4242) in + -- let sock = (create 4240) in + let con = (connect 4240 (dualof SendSendIntServer) "127.0.0.1" 4242) in let = recv con in let = recv talk in let c22 = (send c2) 37 in diff --git a/dev-examples/handoff/client.ldgvnw b/dev-examples/handoff/client.ldgvnw index a4be60c..29d4175 100644 --- a/dev-examples/handoff/client.ldgvnw +++ b/dev-examples/handoff/client.ldgvnw @@ -20,9 +20,9 @@ val add2 (c1: dualof SendInt) = val main : Unit val main = - let sock = (create 4141) in - let con = (connect sock SendInt "127.0.0.1" 4242) in -- This cannot be localhost, since this might break on containerized images + -- let sock = (create 4141) in + let con = (connect 4141 SendInt "127.0.0.1" 4242) in -- This cannot be localhost, since this might break on containerized images let oneint = (send1 con) in - let con2 = (connect sock SendSendOneInt "127.0.0.1" 4343) in + let con2 = (connect 4141 SendSendOneInt "127.0.0.1" 4343) in (send con2) oneint diff --git a/dev-examples/handoff/handoff.ldgvnw b/dev-examples/handoff/handoff.ldgvnw index 149b49b..096ba0b 100644 --- a/dev-examples/handoff/handoff.ldgvnw +++ b/dev-examples/handoff/handoff.ldgvnw @@ -20,8 +20,8 @@ val add2 (c1: dualof SendInt) = val main : Unit val main = - let con = (create 4343) in - let sock = (accept con (dualof SendSendOneInt)) in - let = recv sock in + -- let con = (create 4343) in + let con = (accept 4343 (dualof SendSendOneInt)) in + let = recv con in send2 oneint diff --git a/dev-examples/handoff/server.ldgvnw b/dev-examples/handoff/server.ldgvnw index 56004ce..0a9aa08 100644 --- a/dev-examples/handoff/server.ldgvnw +++ b/dev-examples/handoff/server.ldgvnw @@ -15,6 +15,6 @@ val add2 (c1: dualof SendInt) = val main : Int val main = - let con = (create 4242) in - let sock = (accept con (dualof SendInt)) in - add2 sock + -- let con = (create 4242) in + let con = (accept 4242 (dualof SendInt)) in + add2 con diff --git a/dev-examples/handoff2/client.ldgvnw b/dev-examples/handoff2/client.ldgvnw index ea9d0c3..1e0d29a 100644 --- a/dev-examples/handoff2/client.ldgvnw +++ b/dev-examples/handoff2/client.ldgvnw @@ -17,6 +17,6 @@ val add2 (c1: dualof SendInt) = val main : Unit val main = - let sock = (create 4444) in + let sock = 4444 in let con = (connect sock SendInt "127.0.0.1" 4242 ) in -- This cannot be localhost, since this might break on containerized images send2 con diff --git a/dev-examples/handoff2/handoff.ldgvnw b/dev-examples/handoff2/handoff.ldgvnw index d1fce48..9d0ecfa 100644 --- a/dev-examples/handoff2/handoff.ldgvnw +++ b/dev-examples/handoff2/handoff.ldgvnw @@ -8,7 +8,7 @@ type SendSendOneInt : ! ~ssn = !SendOneInt. Unit val main : Int val main = - let sock = (create 4343) in + let sock = 4343 in let con = (connect sock (dualof SendSendOneInt) "127.0.0.1" 4242) in let = recv con in let = recv oneint in diff --git a/dev-examples/handoff2/server.ldgvnw b/dev-examples/handoff2/server.ldgvnw index 9ab4cac..4fe7c9d 100644 --- a/dev-examples/handoff2/server.ldgvnw +++ b/dev-examples/handoff2/server.ldgvnw @@ -21,7 +21,7 @@ val add2 (c1: dualof SendInt) (c3: SendSendOneInt)= -- Hier problematisch ldgv hat noch kein Konzept wie beim akzeptieren zwischen verschiedenen Types ungerschieden werden kann val main : Int val main = - let sock = (create 4242) in + let sock = 4242 in let con1 = (accept sock (dualof SendInt)) in let con2 = (accept sock (SendSendOneInt)) in add2 con1 con2 diff --git a/dev-examples/simple/client.ldgvnw b/dev-examples/simple/client.ldgvnw index e7d6b0f..ada14e4 100644 --- a/dev-examples/simple/client.ldgvnw +++ b/dev-examples/simple/client.ldgvnw @@ -45,6 +45,6 @@ val lServer (c : TServer) : End = val main : Int val main = - let sock = (create 4343) in + let sock = 4343 in let con = (connect sock TClient "127.0.0.1" 4242 ) in ((lClient con) 42) diff --git a/dev-examples/simple/server.ldgvnw b/dev-examples/simple/server.ldgvnw index 396b133..d64be4d 100644 --- a/dev-examples/simple/server.ldgvnw +++ b/dev-examples/simple/server.ldgvnw @@ -44,7 +44,7 @@ val lServer (c : TServer) : End = val main : Unit val main = - let sock = (create 4242) in + let sock = 4242 in let con = (accept sock (dualof TClient)) in let e = lServer con in let ee = end e in diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 3af8479..35d0e33 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -51,6 +51,8 @@ import qualified Control.Concurrent as MVar import qualified Control.Concurrent as MVar import qualified Control.Concurrent as MVar import qualified Control.Concurrent as MVar +import qualified Control.Concurrent as MVar +import qualified Control.Concurrent as MVar -- import qualified Networking.NetworkConnection as NCon -- import qualified Networking.NetworkConnection as NCon @@ -91,15 +93,18 @@ blame exp = throw $ CastException exp -- | interpret the "main" value in an ldgv file given over stdin interpret :: [Decl] -> IO Value -interpret decls = R.runReaderT (interpretDecl decls) [] +interpret decls = do + sockets <- MVar.newEmptyMVar + MVar.putMVar sockets Map.empty + R.runReaderT (interpretDecl decls) ([], sockets) interpretDecl :: [Decl] -> InterpretM Value interpretDecl (DFun "main" _ e _:_) = interpret' e -interpretDecl (DFun name [] e _:decls) = interpret' e >>= \v -> local (extendEnv name v) (interpretDecl decls) +interpretDecl (DFun name [] e _:decls) = interpret' e >>= \v -> local (\(env, sock) -> ((extendEnv name v) env, sock)) (interpretDecl decls) interpretDecl (DFun name binds e _:decls) = let lambda = foldr (\(mul, id, ty) -> Lam mul id ty) e binds - in interpret' lambda >>= \v -> local (extendEnv name v) (interpretDecl decls) -interpretDecl (DType name _ _ t:decls) = local (extendEnv name $ VType t) (interpretDecl decls) + in interpret' lambda >>= \v -> local (\(env, sock) -> ((extendEnv name v) env, sock)) (interpretDecl decls) +interpretDecl (DType name _ _ t:decls) = local (\(env, sock) -> ((extendEnv name $ VType t) env, sock)) (interpretDecl decls) interpretDecl (_:decls) = interpretDecl decls interpretDecl [] = throw $ LookupException "main" @@ -113,7 +118,7 @@ interpret' e = ask >>= \penv -> eval :: Exp -> InterpretM Value eval = \case Succ e -> interpretMath $ Add (Lit (LInt 1)) e - Rec f x e1 e0 -> ask >>= \env -> return $ VRec env f x e1 e0 + Rec f x e1 e0 -> ask >>= \(env, _) -> return $ VRec env f x e1 e0 NatRec e1 e2 i1 t1 i2 t e3 -> do -- returns a function indexed over e1 (should be a variable pointing to a Nat) -- e1 should be the recursive variable which gets decreased each time the @@ -125,16 +130,16 @@ eval = \case VInt 0 -> interpret' e2 VInt 1 -> do zero <- interpret' e2 - R.local (extendEnv i1 (VInt 0) . extendEnv i2 zero) (interpret' e3) + R.local (\(env, sock) -> ((extendEnv i1 (VInt 0) . extendEnv i2 zero) env, sock)) (interpret' e3) VInt n -> do -- interpret the n-1 case i2 and add it to the env -- together with n before interpreting the body e3 let lowerEnv = extendEnv i1 (VInt $ n-1) - lower <- R.local lowerEnv (interpret' $ NatRec (Var i1) e2 i1 t1 i2 t e3) - R.local (extendEnv i2 lower . lowerEnv) (interpret' e3) + lower <- R.local (\(env,sock) -> (lowerEnv env, sock)) (interpret' $ NatRec (Var i1) e2 i1 t1 i2 t e3) + R.local (\(env, sock) -> ((extendEnv i2 lower . lowerEnv) env, sock)) (interpret' e3) _ -> throw $ RecursorException "Evaluation of 'natrec x...' must yield Nat value" - NewNatRec f n tid ty ez x es -> ask >>= \env -> return $ VNewNatRec env f n tid ty ez x es - Lam _ i _ e -> ask >>= \env -> return $ VFunc env i e + NewNatRec f n tid ty ez x es -> ask >>= \(env, _) -> return $ VNewNatRec env f n tid ty ez x es + Lam _ i _ e -> ask >>= \(env, sock) -> return $ VFunc env i e cast@(Cast e t1 t2) -> do C.traceIO $ "Interpreting cast expression: " ++ pshow cast v <- interpret' e @@ -146,11 +151,12 @@ eval = \case case v of VPair {} -> do C.traceIO $ "Interpreting pair cast expression: Value(" ++ show v ++ ") NFType(" ++ show nft1 ++ ") NFType(" ++ show nft2 ++ ")" - v' <- lift $ reducePairCast v (toNFPair nft1) (toNFPair nft2) + (env, sockets) <- ask + v' <- lift $ reducePairCast sockets v (toNFPair nft1) (toNFPair nft2) maybe (blame cast) return v' _ -> let v' = reduceCast v nft1 nft2 in maybe (blame cast) return v' - Var s -> ask >>= \env -> maybe (throw $ LookupException s) (liftIO . pure) (lookup s env) - Let s e1 e2 -> interpret' e1 >>= \v -> R.local (extendEnv s v) (interpret' e2) + Var s -> ask >>= \(env, _) -> maybe (throw $ LookupException s) (liftIO . pure) (lookup s env) + Let s e1 e2 -> interpret' e1 >>= \v -> R.local (\(env, sock) -> ((extendEnv s v env), sock)) (interpret' e2) Math m -> interpretMath m Lit l -> return (interpretLit l) e@(App e1 e2) -> do @@ -160,15 +166,15 @@ eval = \case interpretApp e val arg Pair mul s e1 e2 -> do v1 <- interpret' e1 - v2 <- R.local (extendEnv s v1) (interpret' e2) + v2 <- R.local (\(env, sock) -> ((extendEnv s v1 env), sock)) (interpret' e2) return $ VPair v1 v2 - LetPair s1 s2 e1 e2 -> interpret' e1 >>= \(VPair v1 v2) -> R.local (extendEnv s2 v2 . extendEnv s1 v1) (interpret' e2) + LetPair s1 s2 e1 e2 -> interpret' e1 >>= \(VPair v1 v2) -> R.local (\(env, sock) -> ((extendEnv s2 v2 . extendEnv s1 v1) env, sock)) (interpret' e2) fst@(Fst e) -> interpret' e >>= \(VPair s1 s2) -> return s1 snd@(Snd e) -> interpret' e >>= \(VPair s1 s2) -> return s2 Fork e -> do - penv <- ask + (penv, sock) <- ask liftIO $ forkIO (do - res <- R.runReaderT (interpret' e) penv + res <- R.runReaderT (interpret' e) (penv, sock) C.traceIO "Ran a forked operation") return VUnit New t -> do @@ -224,7 +230,9 @@ eval = \case val <- interpret' e case val of - VServerSocket mvar clientlist ownport -> do + VInt port -> do + (env, sockets) <- ask + (mvar, clientlist, ownport) <- liftIO $ NS.ensureSocket port sockets -- newuser <- liftIO $ Chan.readChan chan liftIO $ C.traceIO "Searching for correct communicationpartner" newuser <- liftIO $ NS.findFittingClient clientlist t -- There is still an issue @@ -237,16 +245,18 @@ eval = \case used <- liftIO MVar.newEmptyMVar liftIO $ MVar.putMVar used False return $ VChan networkconnection mvar used - _ -> throw $ NotAnExpectedValueException "VServerSocket" val + _ -> throw $ NotAnExpectedValueException "VInt" val Connect e0 t e1 e2-> do r <- liftIO DC.newConnection w <- liftIO DC.newConnection liftIO $ C.traceIO "Client trying to connect" - serversocket <- interpret' e0 - case serversocket of - VServerSocket networkconmapmvar chan ownport -> do + val <- interpret' e0 + case val of + VInt port -> do + (env, sockets) <- ask + (networkconmapmvar, chan, ownport) <- liftIO $ NS.ensureSocket port sockets addressVal <- interpret' e1 case addressVal of VString address -> do @@ -256,24 +266,24 @@ eval = \case liftIO $ NClient.initialConnect networkconmapmvar address (show port) ownport t _ -> throw $ NotAnExpectedValueException "VInt" portVal _ -> throw $ NotAnExpectedValueException "VString" addressVal - _ -> throw $ NotAnExpectedValueException "VServerSocket" serversocket + _ -> throw $ NotAnExpectedValueException "VInt" val e -> throw $ NotImplementedException e -- Exp is only used for blame interpretApp :: Exp -> Value -> Value -> InterpretM Value -interpretApp _ (VFunc env s exp) w = R.local (const $ extendEnv s w env) (interpret' exp) +interpretApp _ (VFunc env s exp) w = R.local (\(cenv, sock) -> ((const $ extendEnv s w env) cenv, sock)) (interpret' exp) interpretApp e (VFuncCast v (FuncType penv s t1 t2) (FuncType penv' s' t1' t2')) w' = do - env0 <- ask + (env0, socketMVar) <- ask let interpretAppCast :: IO Value interpretAppCast = do C.traceIO ("Attempting function cast in application (" ++ show v ++ ") with (" ++ show w' ++ ")") - nft1 <- R.runReaderT (evalType t1) penv - nft1' <- R.runReaderT (evalType t1') penv' + nft1 <- R.runReaderT (evalType t1) (penv, socketMVar) + nft1' <- R.runReaderT (evalType t1') (penv', socketMVar) w <- maybe (blame e) return (reduceCast w' nft1' nft1) - nft2' <- R.runReaderT (evalType t2') (extendEnv s' w' penv') - nft2 <- R.runReaderT (evalType t2) (extendEnv s w penv) - u <- R.runReaderT (interpretApp e v w) env0 + nft2' <- R.runReaderT (evalType t2') (extendEnv s' w' penv', socketMVar) + nft2 <- R.runReaderT (evalType t2) (extendEnv s w penv, socketMVar) + u <- R.runReaderT (interpretApp e v w) (env0, socketMVar) u' <- maybe (blame e) return (reduceCast u nft2 nft2') C.traceIO ("Function cast in application results in: " ++ show u') return u' @@ -283,13 +293,13 @@ interpretApp e rec@(VRec env f n1 e1 e0) (VInt n) | n == 0 = interpret' e0 | n > 0 = do let env' = extendEnv n1 (VInt (n-1)) (extendEnv f rec env) - R.local (const env') (interpret' e1) + R.local (\(env,sock) -> ((const env') env, sock)) (interpret' e1) interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) | n < 0 = throw RecursorNotNatException | n == 0 = interpret' ez | n > 0 = do let env' = extendEnv n1 (VInt (n-1)) (extendEnv f natrec env) - R.local (const env') (interpret' es) + R.local (\(env,sock) -> ((const env') env, sock)) (interpret' es) -- interpretApp _ (VSend v@(VChan _ c handle _ _ _)) w = do interpretApp _ (VSend v@(VChan cc _ usedmvar)) w = do used <- liftIO $ MVar.readMVar usedmvar @@ -348,14 +358,15 @@ evalType = \case then throw RecursorNotNatException else let lower = TNatRec (Lit $ LNat (n-1)) t1 tid t2 - in R.local (extendEnv tid (VType lower)) (evalType t2) + in do + R.local (\(env, sock) -> (extendEnv tid (VType lower) env, sock)) (evalType t2) _ -> throw $ RecursorException "Evaluation of 'natrec x...' must yield Nat value" - TName _ s -> ask >>= \env -> maybe (throw $ LookupException s) (\(VType t) -> evalType t) (lookup s env) + TName _ s -> ask >>= \(env, _) -> maybe (throw $ LookupException s) (\(VType t) -> evalType t) (lookup s env) TLab ls -> return $ NFGType $ GLabel $ labelsFromList ls TFun m _ TDyn TDyn -> return $ NFGType $ GFunc m - TFun m s t1 t2 -> ask >>= \env -> return $ NFFunc $ FuncType env s t1 t2 + TFun m s t1 t2 -> ask >>= \(env, _) -> return $ NFFunc $ FuncType env s t1 t2 TPair _ TDyn TDyn -> return $ NFGType $ GPair - TPair s t1 t2 -> ask >>= \env -> return $ NFPair $ FuncType env s t1 t2 + TPair s t1 t2 -> ask >>= \(env, _) -> return $ NFPair $ FuncType env s t1 t2 TCase exp labels -> interpret' exp >>= \(VLabel l) -> let entry = find (\(l', _) -> l == l') labels in maybe (return NFBot) (evalType . snd) entry @@ -401,21 +412,21 @@ toNFPair :: NFType -> NFType toNFPair (NFGType (GPair)) = NFPair (FuncType [] "x" TDyn TDyn) toNFPair t = t -reducePairCast :: Value -> NFType -> NFType -> IO (Maybe Value) -reducePairCast (VPair v w) (NFPair (FuncType penv s t1 t2)) (NFPair (FuncType penv' s' t1' t2')) = do - mv' <- reduceComponent v (penv, t1) (penv', t1') +reducePairCast :: MVar.MVar (Map.Map Int ServerSocket) -> Value -> NFType -> NFType -> IO (Maybe Value) +reducePairCast sockets (VPair v w) (NFPair (FuncType penv s t1 t2)) (NFPair (FuncType penv' s' t1' t2')) = do + mv' <- reduceComponent sockets v (penv, t1) (penv', t1') case mv' of Nothing -> return Nothing Just v' -> do - mw' <- reduceComponent w ((s, v) : penv, t2) ((s', v') : penv', t2') + mw' <- reduceComponent sockets w ((s, v) : penv, t2) ((s', v') : penv', t2') return $ liftM2 VPair mv' mw' where - reduceComponent :: Value -> (PEnv, Type) -> (PEnv, Type) -> IO (Maybe Value) - reduceComponent v (penv, t) (penv', t') = do - nft <- R.runReaderT (evalType t) penv - nft' <- R.runReaderT (evalType t') penv' + reduceComponent :: MVar.MVar (Map.Map Int ServerSocket) -> Value -> (PEnv, Type) -> (PEnv, Type) -> IO (Maybe Value) + reduceComponent sockets v (penv, t) (penv', t') = do + nft <- R.runReaderT (evalType t) (penv, sockets) + nft' <- R.runReaderT (evalType t') (penv', sockets) return $ reduceCast v nft nft' -reducePairCast _ _ _ = return Nothing +reducePairCast _ _ _ _ = return Nothing equalsType :: NFType -> GType -> Bool equalsType (NFFunc (FuncType _ _ TDyn TDyn)) (GFunc _) = True diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 6b4b4be..cce0a0e 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -29,6 +29,7 @@ import qualified Networking.Common as NC import qualified Config import qualified Networking.NetworkConnection as NCon import qualified Control.Concurrent as MVar +import ProcessEnvironment (ServerSocket) createServer :: Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), MVar.MVar [(String, Syntax.Type)]) createServer port = do @@ -267,4 +268,20 @@ replaceVChanSerial mvar input = case input of replaceVChanSerialPEnv mvar (x:xs) = do newval <- replaceVChanSerial mvar $ snd x rest <- replaceVChanSerialPEnv mvar xs - return $ (fst x, newval):rest \ No newline at end of file + return $ (fst x, newval):rest + +ensureSocket :: Int -> MVar.MVar (Map.Map Int ServerSocket) -> IO ServerSocket +ensureSocket port socketsmvar = do + sockets <- MVar.takeMVar socketsmvar + case Map.lookup port sockets of + Just socket -> do + MVar.putMVar socketsmvar sockets + return socket + Nothing -> do + Config.traceIO "Creating socket!" + (mvar, clientlist) <- createServer port + Config.traceIO "Socket created" + let newsocket = (mvar, clientlist, show port) + let updatedMap = Map.insert port newsocket sockets + MVar.putMVar socketsmvar updatedMap + return newsocket \ No newline at end of file diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index 2d7ea63..ad6719e 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -24,7 +24,7 @@ import qualified Networking.NetworkConnection as Ncon -- import qualified Networking.Common as NC -- | the interpretation monad -type InterpretM a = T.ReaderT PEnv IO a +type InterpretM a = T.ReaderT (PEnv, MVar.MVar (Map.Map Int ServerSocket)) IO a extendEnv :: String -> Value -> PEnv -> PEnv extendEnv = curry (:) @@ -45,6 +45,7 @@ data FuncType = FuncType PEnv String S.Type S.Type instance Show FuncType where show (FuncType _ s t1 t2) = "FuncType " ++ show s ++ " " ++ show t1 ++ " " ++ show t2 +type ServerSocket = (MVar.MVar (Map.Map String (NCon.NetworkConnection Value)), MVar.MVar [(String, Type)], String) type ValueRepr = String From bf1ee5bd1f2f5f406215aba3163dda5803d4b5b7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 3 Jan 2023 23:28:35 +0100 Subject: [PATCH 075/229] Experimental fix for MacOS --- src/Networking/Server.hs | 38 +++++++++++++++++++++++++++----------- 1 file changed, 27 insertions(+), 11 deletions(-) diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index cce0a0e..d4eae2a 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -31,25 +31,41 @@ import qualified Networking.NetworkConnection as NCon import qualified Control.Concurrent as MVar import ProcessEnvironment (ServerSocket) +newtype ServerException = CouldntBindSocket Int + deriving Eq + +instance Show ServerException where + show = \case + CouldntBindSocket port -> "Couldn't bind socket to port " ++ show port + +instance Exception ServerException + createServer :: Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), MVar.MVar [(String, Syntax.Type)]) createServer port = do serverid <- UserID.newRandomUserID - sock <- liftIO $ socket AF_INET Stream 0 - liftIO $ setSocketOption sock ReuseAddr 1 + sock <- socket AF_INET Stream 0 + setSocketOption sock ReuseAddr 1 let hints = defaultHints { addrFlags = [AI_PASSIVE] , addrSocketType = Stream } - addrInfo <- liftIO $ getAddrInfo (Just hints) Nothing $ Just $ show port + addrInfo <- getAddrInfo (Just hints) Nothing $ Just $ show port + + case getIPv4AddrInfo addrInfo of + Just info -> do + bind sock $ addrAddress info + listen sock 2 + mvar <- MVar.newEmptyMVar + MVar.putMVar mvar Map.empty + clientlist <- MVar.newEmptyMVar + MVar.putMVar clientlist [] + forkIO $ acceptClients mvar clientlist sock + return (mvar, clientlist) + Nothing -> throw $ CouldntBindSocket port - liftIO $ bind sock $ addrAddress $ head addrInfo - liftIO $ listen sock 2 - mvar <- MVar.newEmptyMVar - MVar.putMVar mvar Map.empty - clientlist <- MVar.newEmptyMVar - MVar.putMVar clientlist [] - forkIO $ acceptClients mvar clientlist sock - return (mvar, clientlist) +getIPv4AddrInfo :: [AddrInfo] -> Maybe AddrInfo +getIPv4AddrInfo [] = Nothing +getIPv4AddrInfo (x:xs) = if addrFamily x == AF_INET then Just x else getIPv4AddrInfo xs acceptClients :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> Socket -> IO () acceptClients mvar clientlist socket = do From cb6a584b7c8192ea14e985fce52232fcce66d27f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 4 Jan 2023 00:18:21 +0100 Subject: [PATCH 076/229] Slightly more elegant fix for MacOS --- src/Networking/Client.hs | 3 ++- src/Networking/Server.hs | 36 ++++++++++-------------------------- 2 files changed, 12 insertions(+), 27 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 2184edd..f25bc0e 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -74,7 +74,8 @@ tryToSendNetworkMessage networkconnection hostname port message = do Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port Config.traceNetIO $ " Message: " ++ serializedMessage let hints = defaultHints { - addrFlags = [] + addrFamily = AF_INET + , addrFlags = [] , addrSocketType = Stream } Config.traceIO $ "Trying to connect to: " ++ hostname ++":"++port diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index d4eae2a..1bf767e 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -31,41 +31,25 @@ import qualified Networking.NetworkConnection as NCon import qualified Control.Concurrent as MVar import ProcessEnvironment (ServerSocket) -newtype ServerException = CouldntBindSocket Int - deriving Eq - -instance Show ServerException where - show = \case - CouldntBindSocket port -> "Couldn't bind socket to port " ++ show port - -instance Exception ServerException - createServer :: Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), MVar.MVar [(String, Syntax.Type)]) createServer port = do serverid <- UserID.newRandomUserID sock <- socket AF_INET Stream 0 setSocketOption sock ReuseAddr 1 let hints = defaultHints { - addrFlags = [AI_PASSIVE] + addrFamily = AF_INET + , addrFlags = [AI_PASSIVE] , addrSocketType = Stream } addrInfo <- getAddrInfo (Just hints) Nothing $ Just $ show port - - case getIPv4AddrInfo addrInfo of - Just info -> do - bind sock $ addrAddress info - listen sock 2 - mvar <- MVar.newEmptyMVar - MVar.putMVar mvar Map.empty - clientlist <- MVar.newEmptyMVar - MVar.putMVar clientlist [] - forkIO $ acceptClients mvar clientlist sock - return (mvar, clientlist) - Nothing -> throw $ CouldntBindSocket port - -getIPv4AddrInfo :: [AddrInfo] -> Maybe AddrInfo -getIPv4AddrInfo [] = Nothing -getIPv4AddrInfo (x:xs) = if addrFamily x == AF_INET then Just x else getIPv4AddrInfo xs + bind sock $ addrAddress $ head addrInfo + listen sock 2 + mvar <- MVar.newEmptyMVar + MVar.putMVar mvar Map.empty + clientlist <- MVar.newEmptyMVar + MVar.putMVar clientlist [] + forkIO $ acceptClients mvar clientlist sock + return (mvar, clientlist) acceptClients :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> Socket -> IO () acceptClients mvar clientlist socket = do From 61bdabc6569fdc2b201d51b2507e5e7906926441 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 9 Jan 2023 14:17:05 +0100 Subject: [PATCH 077/229] Create TODO --- TODO | 1 + 1 file changed, 1 insertion(+) create mode 100644 TODO diff --git a/TODO b/TODO new file mode 100644 index 0000000..d982499 --- /dev/null +++ b/TODO @@ -0,0 +1 @@ +Check if everything works when a connection is send to another partner and then gets recieved again. \ No newline at end of file From bd69ae6d00b3f7dd2ecc7acbc9df930b04ee35d3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sat, 21 Jan 2023 19:40:29 +0100 Subject: [PATCH 078/229] Made end less code more stable --- dev-examples/bidirhandoff/client.ldgvnw | 6 +- .../bidirhandoff/clienthandoff.ldgvnw | 6 +- dev-examples/bidirhandoff/server.ldgvnw | 6 +- .../bidirhandoff/serverhandoff.ldgvnw | 6 +- .../BugsAssociatedWithThisTest | 1 + .../bidirhandoffWithEnd/client.ldgvnw | 36 ++++++ .../bidirhandoffWithEnd/clienthandoff.ldgvnw | 35 ++++++ .../bidirhandoffWithEnd/server.ldgvnw | 35 ++++++ .../bidirhandoffWithEnd/serverhandoff.ldgvnw | 34 ++++++ src/Interpreter.hs | 2 +- src/Networking/Client.hs | 109 ++++++++++++++---- src/Networking/Messages.hs | 6 +- src/Networking/NetworkConnection.hs | 10 ++ src/Networking/Serialize.hs | 22 ++-- src/Networking/Server.hs | 102 ++++++++++------ src/ValueParsing/ValueGrammar.y | 6 +- src/ValueParsing/ValueTokens.x | 4 + test/Utils.hs | 15 ++- testAdd.sh | 2 + testBidirectional.sh | 2 + testBidirhandoff.sh | 2 + testHandoff.sh | 2 + testHandoff2.sh | 2 + testNW.sh | 8 ++ testNWCount.sh | 8 ++ testNWOld.sh | 14 +++ testOftenBidirhandoff.sh | 3 + testOftenHandoff2.sh | 3 + testSimple.sh | 2 + 29 files changed, 396 insertions(+), 93 deletions(-) create mode 100644 dev-examples/bidirhandoffWithEnd/BugsAssociatedWithThisTest create mode 100644 dev-examples/bidirhandoffWithEnd/client.ldgvnw create mode 100644 dev-examples/bidirhandoffWithEnd/clienthandoff.ldgvnw create mode 100644 dev-examples/bidirhandoffWithEnd/server.ldgvnw create mode 100644 dev-examples/bidirhandoffWithEnd/serverhandoff.ldgvnw create mode 100644 testAdd.sh create mode 100644 testBidirectional.sh create mode 100644 testBidirhandoff.sh create mode 100644 testHandoff.sh create mode 100644 testHandoff2.sh create mode 100644 testNW.sh create mode 100644 testNWCount.sh create mode 100644 testNWOld.sh create mode 100644 testOftenBidirhandoff.sh create mode 100644 testOftenHandoff2.sh create mode 100644 testSimple.sh diff --git a/dev-examples/bidirhandoff/client.ldgvnw b/dev-examples/bidirhandoff/client.ldgvnw index cf01cf3..b846bf8 100644 --- a/dev-examples/bidirhandoff/client.ldgvnw +++ b/dev-examples/bidirhandoff/client.ldgvnw @@ -12,7 +12,7 @@ val send2 (c: SendInt) = let = recv x in let y = ((send x2) 41) in let = recv y in - let y3 = end y2 in + -- let y3 = end y2 in (m + n) val add2 (c1: dualof SendInt) = @@ -20,7 +20,7 @@ val add2 (c1: dualof SendInt) = let c22 = (send c2) 1300 in let = recv c22 in let c32 = (send c3) 37 in - let c4 = end c32 in + -- let c4 = end c32 in (m + n) val main : Int @@ -31,6 +31,6 @@ val main = let = recv x in let con2 = (connect 4343 SendSendIntClient "127.0.0.1" 4340) in let con22 = ((send con2) x2) in - let con23 = end con22 in + -- let con23 = end con22 in (n) diff --git a/dev-examples/bidirhandoff/clienthandoff.ldgvnw b/dev-examples/bidirhandoff/clienthandoff.ldgvnw index 768682d..7ddff05 100644 --- a/dev-examples/bidirhandoff/clienthandoff.ldgvnw +++ b/dev-examples/bidirhandoff/clienthandoff.ldgvnw @@ -12,7 +12,7 @@ val send2 (c: SendInt) = let = recv x in let y = ((send x2) 41) in let = recv y in - let y3 = end y2 in + -- let y3 = end y2 in (m + n) val add2 (c1: dualof SendInt) = @@ -20,7 +20,7 @@ val add2 (c1: dualof SendInt) = let c22 = (send c2) 1300 in let = recv c22 in let c32 = (send c3) 37 in - let c4 = end c32 in + -- let c4 = end c32 in (m + n) val main : Int @@ -30,6 +30,6 @@ val main = let = (recv con) in let x = ((send talk) 41) in let = recv x in - let con2 = end x2 in + -- let con2 = end x2 in (n) diff --git a/dev-examples/bidirhandoff/server.ldgvnw b/dev-examples/bidirhandoff/server.ldgvnw index 16158da..ef86806 100644 --- a/dev-examples/bidirhandoff/server.ldgvnw +++ b/dev-examples/bidirhandoff/server.ldgvnw @@ -12,7 +12,7 @@ val send2 (c: SendInt) = let = recv x in let y = ((send x2) 41) in let = recv y in - let y3 = end y2 in + -- let y3 = end y2 in (m + n) val add2 (c1: dualof SendInt) = @@ -20,7 +20,7 @@ val add2 (c1: dualof SendInt) = let c22 = (send c2) 1300 in let = recv c22 in let c32 = (send c3) 37 in - let c4 = end c32 in + -- let c4 = end c32 in (m + n) val main : Int @@ -31,5 +31,5 @@ val main = let c22 = (send c2) 1300 in let con2 = (accept 4242 (SendSendIntServer)) in let con3 = ((send con2) c22) in - let con4 = end con3 in + -- let con4 = end con3 in (m) diff --git a/dev-examples/bidirhandoff/serverhandoff.ldgvnw b/dev-examples/bidirhandoff/serverhandoff.ldgvnw index 9fc0674..95dbe40 100644 --- a/dev-examples/bidirhandoff/serverhandoff.ldgvnw +++ b/dev-examples/bidirhandoff/serverhandoff.ldgvnw @@ -12,7 +12,7 @@ val send2 (c: SendInt) = let = recv x in let y = ((send x2) 41) in let = recv y in - let y3 = end y2 in + -- let y3 = end y2 in (m + n) val add2 (c1: dualof SendInt) = @@ -20,7 +20,7 @@ val add2 (c1: dualof SendInt) = let c22 = (send c2) 1300 in let = recv c22 in let c32 = (send c3) 37 in - let c4 = end c32 in + -- let c4 = end c32 in (m + n) val main : Int @@ -30,5 +30,5 @@ val main = let = recv con in let = recv talk in let c22 = (send c2) 37 in - let con4 = end c22 in + -- let con4 = end c22 in (m) diff --git a/dev-examples/bidirhandoffWithEnd/BugsAssociatedWithThisTest b/dev-examples/bidirhandoffWithEnd/BugsAssociatedWithThisTest new file mode 100644 index 0000000..40a0401 --- /dev/null +++ b/dev-examples/bidirhandoffWithEnd/BugsAssociatedWithThisTest @@ -0,0 +1 @@ +In some cases when start order is server client clienthandoff serverhandoff communication might not end properly \ No newline at end of file diff --git a/dev-examples/bidirhandoffWithEnd/client.ldgvnw b/dev-examples/bidirhandoffWithEnd/client.ldgvnw new file mode 100644 index 0000000..cf01cf3 --- /dev/null +++ b/dev-examples/bidirhandoffWithEnd/client.ldgvnw @@ -0,0 +1,36 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. ?Int. !Int. ?Int. Unit +type SendIntClient : ! ~ssn = !Int. ?Int. Unit +type SendSendIntClient : ! ~ssn = !SendIntClient. Unit +type SendIntServer : ! ~ssn = ?Int. !Int. Unit +type SendSendIntServer : ! ~ssn = !SendIntServer. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let = recv x in + let y = ((send x2) 41) in + let = recv y in + let y3 = end y2 in + (m + n) + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let c22 = (send c2) 1300 in + let = recv c22 in + let c32 = (send c3) 37 in + let c4 = end c32 in + (m + n) + +val main : Int +val main = + -- let sock = (create 4343) in + let con = (connect 4343 SendInt "127.0.0.1" 4242 ) in -- This cannot be localhost, since this might break on containerized images + let x = ((send con) 1) in + let = recv x in + let con2 = (connect 4343 SendSendIntClient "127.0.0.1" 4340) in + let con22 = ((send con2) x2) in + let con23 = end con22 in + (n) + diff --git a/dev-examples/bidirhandoffWithEnd/clienthandoff.ldgvnw b/dev-examples/bidirhandoffWithEnd/clienthandoff.ldgvnw new file mode 100644 index 0000000..768682d --- /dev/null +++ b/dev-examples/bidirhandoffWithEnd/clienthandoff.ldgvnw @@ -0,0 +1,35 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. ?Int. !Int. ?Int. Unit +type SendIntClient : ! ~ssn = !Int. ?Int. Unit +type SendSendIntClient : ! ~ssn = !SendIntClient. Unit +type SendIntServer : ! ~ssn = ?Int. !Int. Unit +type SendSendIntServer : ! ~ssn = !SendIntServer. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let = recv x in + let y = ((send x2) 41) in + let = recv y in + let y3 = end y2 in + (m + n) + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let c22 = (send c2) 1300 in + let = recv c22 in + let c32 = (send c3) 37 in + let c4 = end c32 in + (m + n) + +val main : Int +val main = + -- let sock = (create 4340) in + let con = (accept 4340 (dualof SendSendIntClient)) in -- This cannot be localhost, since this might break on containerized images + let = (recv con) in + let x = ((send talk) 41) in + let = recv x in + let con2 = end x2 in + (n) + diff --git a/dev-examples/bidirhandoffWithEnd/server.ldgvnw b/dev-examples/bidirhandoffWithEnd/server.ldgvnw new file mode 100644 index 0000000..16158da --- /dev/null +++ b/dev-examples/bidirhandoffWithEnd/server.ldgvnw @@ -0,0 +1,35 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. ?Int. !Int. ?Int. Unit +type SendIntClient : ! ~ssn = !Int. ?Int. Unit +type SendSendIntClient : ! ~ssn = !SendIntClient. Unit +type SendIntServer : ! ~ssn = ?Int. !Int. Unit +type SendSendIntServer : ! ~ssn = !SendIntServer. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let = recv x in + let y = ((send x2) 41) in + let = recv y in + let y3 = end y2 in + (m + n) + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let c22 = (send c2) 1300 in + let = recv c22 in + let c32 = (send c3) 37 in + let c4 = end c32 in + (m + n) + +val main : Int +val main = + -- let sock = (create 4242) in + let con = (accept 4242 (dualof SendInt)) in + let = recv con in + let c22 = (send c2) 1300 in + let con2 = (accept 4242 (SendSendIntServer)) in + let con3 = ((send con2) c22) in + let con4 = end con3 in + (m) diff --git a/dev-examples/bidirhandoffWithEnd/serverhandoff.ldgvnw b/dev-examples/bidirhandoffWithEnd/serverhandoff.ldgvnw new file mode 100644 index 0000000..9fc0674 --- /dev/null +++ b/dev-examples/bidirhandoffWithEnd/serverhandoff.ldgvnw @@ -0,0 +1,34 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. ?Int. !Int. ?Int. Unit +type SendIntClient : ! ~ssn = !Int. ?Int. Unit +type SendSendIntClient : ! ~ssn = !SendIntClient. Unit +type SendIntServer : ! ~ssn = ?Int. !Int. Unit +type SendSendIntServer : ! ~ssn = !SendIntServer. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let = recv x in + let y = ((send x2) 41) in + let = recv y in + let y3 = end y2 in + (m + n) + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let c22 = (send c2) 1300 in + let = recv c22 in + let c32 = (send c3) 37 in + let c4 = end c32 in + (m + n) + +val main : Int +val main = + -- let sock = (create 4240) in + let con = (connect 4240 (dualof SendSendIntServer) "127.0.0.1" 4242) in + let = recv con in + let = recv talk in + let c22 = (send c2) 37 in + let con4 = end c22 in + (m) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 35d0e33..78c2881 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -304,7 +304,7 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) interpretApp _ (VSend v@(VChan cc _ usedmvar)) w = do used <- liftIO $ MVar.readMVar usedmvar if used then throw $ VChanIsUsedException $ show v else do - liftIO $ NClient.sendValue cc w + liftIO $ NClient.sendValue cc w (10) -- Disable old VChan newV <- liftIO $ disableOldVChan v diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index f25bc0e..6305f69 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -28,6 +28,7 @@ import qualified Networking.NetworkConnection as NCon import qualified Control.Concurrent as MVar import qualified Config import qualified Networking.Serialize as NSerialize +import Control.Monad newtype ClientException = NoIntroductionException String @@ -40,8 +41,8 @@ instance Show ClientException where instance Exception ClientException -sendValue :: NetworkConnection Value -> Value -> IO () -sendValue networkconnection val = do +sendValue :: NetworkConnection Value -> Value -> Int -> IO () +sendValue networkconnection val resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port -> do @@ -49,7 +50,7 @@ sendValue networkconnection val = do DC.writeMessage (ncWrite networkconnection) valcleaned -- catch (tryToSend networkconnection hostname port val valcleaned) $ printConErr hostname port catch (do - tryToSendNetworkMessage networkconnection hostname port (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) valcleaned) + tryToSendNetworkMessage networkconnection hostname port (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) valcleaned) resendOnError sendVChanMessages hostname port val disableVChans val ) $ printConErr hostname port @@ -57,18 +58,18 @@ sendValue networkconnection val = do NCon.Emulated -> DC.writeMessage (ncWrite networkconnection) val -- MVar.putMVar (ncConnectionState networkconnection) connectionstate -sendNetworkMessage :: NetworkConnection Value -> Messages -> IO () -sendNetworkMessage networkconnection message = do +sendNetworkMessage :: NetworkConnection Value -> Messages -> Int -> IO () +sendNetworkMessage networkconnection message resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port -> do - catch ( tryToSendNetworkMessage networkconnection hostname port message ) $ printConErr hostname port + catch ( tryToSendNetworkMessage networkconnection hostname port message resendOnError) $ printConErr hostname port NCon.Disconnected -> Config.traceIO "Error when sending message: This channel is disconnected" NCon.Emulated -> pure () --MVar.putMVar (ncConnectionState networkconnection) connectionstate -tryToSendNetworkMessage :: NetworkConnection Value -> String -> String -> Messages -> IO () -tryToSendNetworkMessage networkconnection hostname port message = do +tryToSendNetworkMessage :: NetworkConnection Value -> String -> String -> Messages -> Int -> IO () +tryToSendNetworkMessage networkconnection hostname port message resendOnError = do serializedMessage <- NSerialize.serialize message Config.traceNetIO $ "Sending message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection) ++ " to: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkconnection) Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port @@ -78,24 +79,61 @@ tryToSendNetworkMessage networkconnection hostname port message = do , addrFlags = [] , addrSocketType = Stream } - Config.traceIO $ "Trying to connect to: " ++ hostname ++":"++port - addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port - clientsocket <- NC.openSocketNC $ head addrInfo - connect clientsocket $ addrAddress $ head addrInfo - handle <- NC.getHandle clientsocket - NC.sendMessage message handle - - Config.traceIO "Waiting for response" - mbyresponse <- recieveResponse handle - hClose handle + response <- MVar.newEmptyMVar + forkIO (do + Config.traceNetIO $ "Trying to connect to: " ++ hostname ++":"++port + addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port + Config.traceNetIO "Trying to open socket" + clientsocket <- NC.openSocketNC $ head addrInfo + Config.traceNetIO "Trying to connect" + -- This sometimes fails + connect clientsocket $ addrAddress $ head addrInfo + Config.traceNetIO "Connected" + handle <- NC.getHandle clientsocket + Config.traceNetIO "Trying to send!" + NC.sendMessage message handle + + Config.traceNetIO "Waiting for response" + mbyresponse <- recieveResponse handle + hClose handle + MVar.putMVar response mbyresponse + ) + mbyresponse <- getResp response 10 + + case mbyresponse of Just response -> case response of - Okay -> Config.traceIO "Message okay" + Okay -> Config.traceNetIO $ "Message okay: "++serializedMessage Redirect host port -> do - Config.traceIO "Communication partner changed address, resending" + Config.traceNetIO "Communication partner changed address, resending" NCon.changePartnerAddress networkconnection host port - tryToSendNetworkMessage networkconnection host port message - Nothing -> Config.traceIO "Error when recieving response" + tryToSendNetworkMessage networkconnection host port message resendOnError + Wait -> do + Config.traceNetIO "Communication out of sync lets wait!" + threadDelay 1000000 + tryToSendNetworkMessage networkconnection hostname port message resendOnError + _ -> Config.traceNetIO "Unknown communication error" + + Nothing -> do + Config.traceNetIO "Error when recieving response" + connectionstate <- MVar.readMVar $ ncConnectionState networkconnection + case connectionstate of + NCon.Connected newhostname newport -> if resendOnError /= 0 then do + Config.traceNetIO $ "Old communication partner offline! New communication partner: " ++ newhostname ++ ":" ++ newport + tryToSendNetworkMessage networkconnection newhostname newport message (resendOnError-1) + else Config.traceNetIO "Old communication partner offline! No longer retrying" + + _ -> Config.traceNetIO "Error when sending message: This channel is disconnected while sending" + where + getResp mvar count = do + res <- tryTakeMVar mvar + case res of + Just response -> return response + Nothing -> if count /= 0 then do + threadDelay 100000 + getResp mvar (count-1) + else return Nothing + printConErr :: String -> String -> IOException -> IO () printConErr hostname port err = Config.traceIO $ "Communication Partner " ++ hostname ++ ":" ++ port ++ "not found!" @@ -136,10 +174,18 @@ sendVChanMessages newhost newport input = case input of VRec penv a b c d -> sendVChanMessagesPEnv newhost newport penv VNewNatRec penv a b c d e f g -> sendVChanMessagesPEnv newhost newport penv VChan nc _ _-> do + {- sendNetworkMessage nc (Messages.ChangePartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID nc) newhost newport) _ <- MVar.takeMVar $ ncConnectionState nc Config.traceNetIO $ "Set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport + MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest newhost newport-} + + + oldconnectionstate <- MVar.takeMVar $ ncConnectionState nc MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest newhost newport + tempnetcon <- NCon.newNetworkConnectionAllowingMaybe (NCon.ncPartnerUserID nc) (NCon.ncOwnUserID nc) (NCon.csHostname oldconnectionstate) (NCon.csPort oldconnectionstate) + sendNetworkMessage tempnetcon (Messages.ChangePartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID nc) newhost newport) 5 + Config.traceNetIO $ "Set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport _ -> return () where sendVChanMessagesPEnv :: String -> String -> [(String, Value)] -> IO () @@ -155,7 +201,7 @@ closeConnection con = do NCon.Connected hostname port -> do connectionError <- MVar.newEmptyMVar MVar.putMVar connectionError False - catch ( tryToSendNetworkMessage con hostname port (RequestClose $ Data.Maybe.fromMaybe "" $ ncOwnUserID con) ) (\exception -> do + catch ( tryToSendNetworkMessage con hostname port (RequestClose $ Data.Maybe.fromMaybe "" $ ncOwnUserID con) 0) (\exception -> do printConErr hostname port exception _ <- MVar.takeMVar connectionError -- If we cannot communicate with them just close the connection MVar.putMVar connectionError True @@ -175,7 +221,22 @@ closeConnection con = do recieveResponse :: Handle -> IO (Maybe Responses) recieveResponse handle = do - NC.recieveMessage handle VG.parseResponses (\_ -> return Nothing) (\_ des -> return $ Just des) + retVal <- MVar.newEmptyMVar + forkIO $ NC.recieveMessage handle VG.parseResponses (\_ -> MVar.putMVar retVal Nothing) (\_ des -> MVar.putMVar retVal $ Just des) + waitForResponse retVal 100 + where + waitForResponse :: MVar.MVar (Maybe Responses) -> Int -> IO (Maybe Responses) + waitForResponse mvar count = do + result <- MVar.tryTakeMVar mvar + case result of + Just mbyResponse -> do + -- Config.traceNetIO "Got response" + return mbyResponse + Nothing -> if count /= 0 then do + -- Config.traceNetIO $ "Waiting for response: " ++ show count + threadDelay 10000 + waitForResponse mvar (count-1) + else return Nothing -- This waits until the handle is established getClientHandle :: String -> String -> IO Handle diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs index 3bc9f66..00467ce 100644 --- a/src/Networking/Messages.hs +++ b/src/Networking/Messages.hs @@ -18,6 +18,7 @@ data Messages | SyncIncoming UserID [Value] | RequestSync UserID | ChangePartnerAddress UserID Hostname Port + | IntroduceNewPartnerAddress UserID Port | RequestClose UserID deriving Eq @@ -26,6 +27,7 @@ data Responses | Okay | OkayClose | OkayIntroduce UserID + | Wait getUserID :: Messages -> String getUserID = \case @@ -37,6 +39,4 @@ getUserID = \case RequestSync p -> p ChangePartnerAddress p _ _ -> p RequestClose p -> p - - - + IntroduceNewPartnerAddress p _ -> p \ No newline at end of file diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index 1a98f48..ac09d8a 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -24,6 +24,16 @@ newNetworkConnection partnerID ownID hostname port = do MVar.putMVar reqClose False return $ NetworkConnection read write (Just partnerID) (Just ownID) connectionstate reqClose +newNetworkConnectionAllowingMaybe :: Maybe String -> Maybe String -> String -> String -> IO (NetworkConnection a) +newNetworkConnectionAllowingMaybe partnerID ownID hostname port = do + read <- newConnection + write <- newConnection + connectionstate <- MVar.newEmptyMVar + MVar.putMVar connectionstate $ Connected hostname port + reqClose <- MVar.newEmptyMVar + MVar.putMVar reqClose False + return $ NetworkConnection read write partnerID ownID connectionstate reqClose + createNetworkConnection :: [a] -> Int -> [a] -> Int -> Maybe String -> Maybe String -> String -> String -> IO (NetworkConnection a) createNetworkConnection readList readNew writeList writeNew partnerID ownID hostname port = do diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index 7602c5f..1408f6c 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -37,17 +37,19 @@ instance Serializable Responses where Okay -> return "NOkay" OkayClose -> return "NOkayClose" OkayIntroduce u -> serializeLabeledEntry "NOkayIntroduce" u + Wait -> return "NWait" instance Serializable Messages where - serialize = \case - Introduce p -> serializeLabeledEntry "NIntroduce" p - IntroduceClient p port t -> serializeLabeledEntryMulti "NIntroduceClient" p $ sNext port $ sLast t - IntroduceServer p -> serializeLabeledEntry "NIntroduceServer" p - NewValue p v -> serializeLabeledEntryMulti "NNewValue" p $ sLast v - SyncIncoming p vs -> serializeLabeledEntryMulti "NSyncIncoming" p $ sLast vs - RequestSync p -> serializeLabeledEntry "NRequestSync" p - ChangePartnerAddress p h port -> serializeLabeledEntryMulti "NChangePartnerAddress" p $ sNext h $ sLast port - RequestClose p -> serializeLabeledEntry "NRequestClose" p + serialize = \case + Introduce p -> serializeLabeledEntry "NIntroduce" p + IntroduceClient p port t -> serializeLabeledEntryMulti "NIntroduceClient" p $ sNext port $ sLast t + IntroduceServer p -> serializeLabeledEntry "NIntroduceServer" p + NewValue p v -> serializeLabeledEntryMulti "NNewValue" p $ sLast v + SyncIncoming p vs -> serializeLabeledEntryMulti "NSyncIncoming" p $ sLast vs + RequestSync p -> serializeLabeledEntry "NRequestSync" p + ChangePartnerAddress p h port -> serializeLabeledEntryMulti "NChangePartnerAddress" p $ sNext h $ sLast port + IntroduceNewPartnerAddress u p -> serializeLabeledEntryMulti "NIntroduceNewPartnerAddress" u $ sLast p + RequestClose p -> serializeLabeledEntry "NRequestClose" p instance Serializable (NCon.NetworkConnection Value) where serialize con = do @@ -65,7 +67,7 @@ instance Serializable (NCon.DirectionalConnection Value) where instance Serializable NCon.ConnectionState where serialize = \case - NCon.Connected hostname port -> serializeLabeledEntryMulti "SConnected" hostname $ sLast port + NCon.Connected hostname port-> serializeLabeledEntryMulti "SConnected" hostname $ sLast port _ -> throw $ UnserializableException "VChan can only be serialized when in Connected mode" instance Serializable Value where diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 1bf767e..8c4cd89 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -48,27 +48,27 @@ createServer port = do MVar.putMVar mvar Map.empty clientlist <- MVar.newEmptyMVar MVar.putMVar clientlist [] - forkIO $ acceptClients mvar clientlist sock + forkIO $ acceptClients mvar clientlist sock $ show port return (mvar, clientlist) -acceptClients :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> Socket -> IO () -acceptClients mvar clientlist socket = do +acceptClients :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> Socket -> String -> IO () +acceptClients mvar clientlist socket ownport = do Config.traceIO "Waiting for clients" clientsocket <- accept socket Config.traceIO "Accepted new client" - forkIO $ acceptClient mvar clientlist clientsocket - acceptClients mvar clientlist socket + forkIO $ acceptClient mvar clientlist clientsocket ownport + acceptClients mvar clientlist socket ownport -- In the nothing case we shoud wait a few seconds for other messages to resolve the issue -acceptClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> IO () -acceptClient mvar clientlist clientsocket = do +acceptClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> String -> IO () +acceptClient mvar clientlist clientsocket ownport = do hdl <- NC.getHandle $ fst clientsocket - NC.recieveMessage hdl VG.parseMessages (\_ -> return ()) $ handleClient mvar clientlist clientsocket hdl + NC.recieveMessage hdl VG.parseMessages (\_ -> return ()) $ handleClient mvar clientlist clientsocket hdl ownport hClose hdl -handleClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> Messages -> IO () -handleClient mvar clientlist clientsocket hdl message deserialmessages = do +handleClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Messages -> IO () +handleClient mvar clientlist clientsocket hdl ownport message deserialmessages = do let userid = getUserID deserialmessages netcon <- MVar.takeMVar mvar redirectRequest <- checkRedirectRequest netcon userid @@ -76,34 +76,58 @@ handleClient mvar clientlist clientsocket hdl message deserialmessages = do case Map.lookup userid netcon of Just networkcon -> do Config.traceNetIO $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) + if redirectRequest then sendRedirect hdl netcon userid else do + case deserialmessages of + NewValue userid val -> do + handleNewValue mvar userid val + NC.sendMessage Messages.Okay hdl + IntroduceClient userid clientport syntype-> do + handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype + -- Okay message is handled in handle introduce + ChangePartnerAddress userid hostname port -> do + handleChangePartnerAddress mvar userid hostname port ownport + NC.sendMessage Messages.Okay hdl + RequestSync userid -> do + handleRequestSync mvar userid + NC.sendMessage Messages.Okay hdl + SyncIncoming userid values -> do + handleSyncIncoming mvar userid values + NC.sendMessage Messages.Okay hdl + RequestClose userid -> do + handleRequestClose mvar userid + NC.sendMessage Messages.Okay hdl + IntroduceNewPartnerAddress userid port -> do + networkconnectionmap <- MVar.takeMVar mvar + case Map.lookup userid networkconnectionmap of + Just networkconnection -> do -- Change to current network address + case snd clientsocket of + SockAddrInet _ hostname -> NCon.changePartnerAddress networkconnection (hostaddressTypeToString hostname) port + _ -> return () + MVar.putMVar mvar networkconnectionmap + -- For some reason constate doesn't seem to properly apply MVar.putMVar mvar networkconnectionmap + + Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that + NC.sendMessage Messages.Okay hdl + + _ -> do + serial <- NSerialize.serialize deserialmessages + Config.traceIO $ "Error unsupported networkmessage: "++ serial + NC.sendMessage Messages.Okay hdl Nothing -> do Config.traceNetIO "Recieved message from unknown connection!" + if redirectRequest then sendRedirect hdl netcon userid else do + case deserialmessages of + IntroduceClient userid clientport syntype-> do + handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype + -- Okay message is handled in handle introduce + _ -> do + serial <- NSerialize.serialize deserialmessages + Config.traceIO $ "Error unsupported networkmessage: "++ serial + Config.traceIO $ "This is probably a timing issue! Lets resend later" + NC.sendMessage Messages.Wait hdl Config.traceNetIO $ " Message: " ++ message - if redirectRequest then sendRedirect hdl netcon userid else do - case deserialmessages of - NewValue userid val -> do - handleNewValue mvar userid val - NC.sendMessage Messages.Okay hdl - IntroduceClient userid clientport syntype-> do - handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype - -- Okay message is handled in handle introduce - ChangePartnerAddress userid hostname port -> do - handleChangePartnerAddress mvar userid hostname port - NC.sendMessage Messages.Okay hdl - RequestSync userid -> do - handleRequestSync mvar userid - NC.sendMessage Messages.Okay hdl - SyncIncoming userid values -> do - handleSyncIncoming mvar userid values - NC.sendMessage Messages.Okay hdl - RequestClose userid -> do - handleRequestClose mvar userid - NC.sendMessage Messages.Okay hdl - _ -> do - serial <- NSerialize.serialize deserialmessages - Config.traceIO $ "Error unsupported networkmessage: "++ serial - NC.sendMessage Messages.Okay hdl + checkRedirectRequest :: Map.Map String (NetworkConnection Value) -> String -> IO Bool checkRedirectRequest ncmap userid = do @@ -162,13 +186,15 @@ handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype MVar.putMVar mvar networkconnectionmap NC.sendMessage Messages.Okay hdl -handleChangePartnerAddress :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> IO () -handleChangePartnerAddress mvar userid hostname port = do +handleChangePartnerAddress :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> String -> IO () +handleChangePartnerAddress mvar userid hostname port ownport = do networkconnectionmap <- MVar.takeMVar mvar case Map.lookup userid networkconnectionmap of Just networkconnection -> do -- Change to current network address NCon.changePartnerAddress networkconnection hostname port -- For some reason constate doesn't seem to properly apply + + NClient.sendNetworkMessage networkconnection (Messages.IntroduceNewPartnerAddress (Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) ownport) 5 MVar.putMVar mvar networkconnectionmap Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that @@ -179,7 +205,7 @@ handleRequestSync mvar userid = do case Map.lookup userid networkconnectionmap of Just networkconnection -> do -- Change to current network address writevals <- ND.allMessages $ ncWrite networkconnection - NClient.sendNetworkMessage networkconnection (SyncIncoming (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) writevals) + NClient.sendNetworkMessage networkconnection (SyncIncoming (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) writevals) 5 othing -> return () handleSyncIncoming :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> [Value] -> IO () @@ -257,7 +283,7 @@ replaceVChanSerial mvar input = case input of networkconnection <- createNetworkConnectionS r w p o c ncmap <- MVar.takeMVar mvar MVar.putMVar mvar $ Map.insert p networkconnection ncmap - NClient.sendNetworkMessage networkconnection $ RequestSync o + NClient.sendNetworkMessage networkconnection (RequestSync o) 5 used<- MVar.newEmptyMVar MVar.putMVar used False return $ VChan networkconnection mvar used diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 58a3570..1780855 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -122,11 +122,13 @@ import Networking.Messages nsyncincoming { T _ T.NSyncIncoming } nrequestsync { T _ T.NRequestSync } nchangepartneraddress {T _ T.NChangePartnerAddress } + nintroducenewpartneraddress {T _ T.NIntroduceNewPartnerAddress} nredirect { T _ T.NRedirect} nokay { T _ T.NOkay} nrequestclose { T _ T.NRequestClose } nokayclose { T _ T.NOkayClose} nokayintroduce { T _ T.NOkayIntroduce } + nwait { T _ T.NWait} gunit { T _ T.GUnit } glabel { T _ T.GLabel } @@ -285,12 +287,14 @@ Messages : nintroduce '(' String ')' {Introduce $3} | nsyncincoming '(' String ')''(' SValuesArray ')' {SyncIncoming $3 $6} | nrequestsync '(' String ')' {RequestSync $3} | nchangepartneraddress '(' String ')' '(' String ')' '(' String ')' {ChangePartnerAddress $3 $6 $9} + | nintroducenewpartneraddress '(' String ')' '(' String ')' {IntroduceNewPartnerAddress $3 $6} | nrequestclose '(' String ')' {RequestClose $3} Responses : nredirect '(' String ')' '(' String ')' {Redirect $3 $6} | nokay {Okay} | nokayclose {OkayClose} | nokayintroduce '(' String ')' {OkayIntroduce $3} + | nwait {Wait} PEnvEntry : penventry '(' String ')' '(' Values ')' {($3, $6)} @@ -358,4 +362,4 @@ showToken t = "›" ++ show t ++ "‹" trimQuote :: String -> String trimQuote (_:xs) = init xs -} +} \ No newline at end of file diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index c47f703..d918483 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -135,11 +135,13 @@ tokens :- "NSyncIncoming" { tok $ const NSyncIncoming } "NRequestSync" { tok $ const NRequestSync } "NChangePartnerAddress" { tok $ const NChangePartnerAddress } + "NIntroduceNewPartnerAddress" { tok $ const NIntroduceNewPartnerAddress} "NRedirect" { tok $ const NRedirect } "NOkay" { tok $ const NOkay } "NRequestClose" { tok $ const NRequestClose } "NOkayClose" { tok $ const NOkayClose } "NOkayIntroduce" { tok $ const NOkayIntroduce } + "NWait" { tok $ const NWait} Double\:[\-]?[0-9]+[\.][0-9]+ { tok $ Double . read . (drop 7) } Int\:[\-]?[0-9]+ { tok $ Int . read . (drop 4)} @@ -261,11 +263,13 @@ data Token | NSyncIncoming | NRequestSync | NChangePartnerAddress + | NIntroduceNewPartnerAddress | NRedirect | NOkay | NRequestClose | NOkayClose | NOkayIntroduce + | NWait | String String | Int Int diff --git a/test/Utils.hs b/test/Utils.hs index 0da4917..aa6f869 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -6,6 +6,7 @@ import Interpreter import ProcessEnvironment import Control.Monad.Reader (runReaderT) import Test.Hspec +import Control.Concurrent.MVar shouldParseDecl :: HasCallStack => String -> Decl -> Expectation shouldParseDecl source expected = @@ -18,7 +19,8 @@ raiseFailure msg = do shouldInterpretTo :: [Decl] -> Value -> Expectation shouldInterpretTo givenDecls expectedValue = do - value <- runReaderT (interpretDecl givenDecls) [] + mvar <- newEmptyMVar + value <- runReaderT (interpretDecl givenDecls) ([], mvar) value `shouldBe` expectedValue shouldThrowCastException :: [Decl] -> Expectation @@ -26,12 +28,17 @@ shouldThrowCastException givenDecls = let isCastException :: InterpreterException -> Bool isCastException (CastException _) = True isCastException _ = False - in runReaderT (interpretDecl givenDecls) [] `shouldThrow` isCastException + in do + mvar <- newEmptyMVar + runReaderT (interpretDecl givenDecls) ([], mvar) `shouldThrow` isCastException shouldThrowInterpreterException :: Decl -> InterpreterException -> Expectation -shouldThrowInterpreterException given except = runReaderT (interpretDecl [given]) [] `shouldThrow` (== except) +shouldThrowInterpreterException given except = do + mvar <- newEmptyMVar + runReaderT (interpretDecl [given]) ([], mvar) `shouldThrow` (== except) shouldInterpretTypeTo :: Type -> NFType -> Expectation shouldInterpretTypeTo t expected = do - nft <- runReaderT (evalType t) [] + mvar <- newEmptyMVar + nft <- runReaderT (evalType t) ([], mvar) nft `shouldBe` expected diff --git a/testAdd.sh b/testAdd.sh new file mode 100644 index 0000000..a57d1a4 --- /dev/null +++ b/testAdd.sh @@ -0,0 +1,2 @@ +clear; echo "Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/add/server.ldgvnw & stack run ldgv -- interpret < dev-examples/add/client.ldgvnw & wait); +exit; \ No newline at end of file diff --git a/testBidirectional.sh b/testBidirectional.sh new file mode 100644 index 0000000..f8fed7d --- /dev/null +++ b/testBidirectional.sh @@ -0,0 +1,2 @@ +clear; echo "Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirectional/client.ldgvnw & wait); +exit; \ No newline at end of file diff --git a/testBidirhandoff.sh b/testBidirhandoff.sh new file mode 100644 index 0000000..e1c18b8 --- /dev/null +++ b/testBidirhandoff.sh @@ -0,0 +1,2 @@ +clear; echo "Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/client.ldgvnw & wait); +exit; \ No newline at end of file diff --git a/testHandoff.sh b/testHandoff.sh new file mode 100644 index 0000000..1e622ab --- /dev/null +++ b/testHandoff.sh @@ -0,0 +1,2 @@ +clear; echo "Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff/client.ldgvnw & wait); +exit; \ No newline at end of file diff --git a/testHandoff2.sh b/testHandoff2.sh new file mode 100644 index 0000000..ae9c227 --- /dev/null +++ b/testHandoff2.sh @@ -0,0 +1,2 @@ +clear; echo "Handoff2"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/client.ldgvnw & wait); +exit; \ No newline at end of file diff --git a/testNW.sh b/testNW.sh new file mode 100644 index 0000000..cdaef57 --- /dev/null +++ b/testNW.sh @@ -0,0 +1,8 @@ +for i in {1..100}; do + bash testAdd.sh; + bash testSimple.sh; + bash testBidirectional.sh; + bash testHandoff.sh; + bash testHandoff2.sh; + bash testBidirhandoff.sh; +done \ No newline at end of file diff --git a/testNWCount.sh b/testNWCount.sh new file mode 100644 index 0000000..e29e4a4 --- /dev/null +++ b/testNWCount.sh @@ -0,0 +1,8 @@ +for i in {1..100}; do + clear; echo "$i Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/add/server.ldgvnw & stack run ldgv -- interpret < dev-examples/add/client.ldgvnw & wait); + clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/simple/server.ldgvnw & stack run ldgv -- interpret < dev-examples/simple/client.ldgvnw & wait); + clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirectional/client.ldgvnw & wait); + clear; echo "$i Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff/client.ldgvnw & wait); + clear; echo "$i Handoff2"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/client.ldgvnw & wait); + clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/client.ldgvnw & wait); +done \ No newline at end of file diff --git a/testNWOld.sh b/testNWOld.sh new file mode 100644 index 0000000..05396c2 --- /dev/null +++ b/testNWOld.sh @@ -0,0 +1,14 @@ +for i in {1..100}; do + clear; echo "Add"; stack run ldgv -- interpret < dev-examples/add/server.ldgvnw & stack run ldgv -- interpret < dev-examples/add/client.ldgvnw; + sleep 0.5; + clear; echo "Simple"; stack run ldgv -- interpret < dev-examples/simple/server.ldgvnw & stack run ldgv -- interpret < dev-examples/simple/client.ldgvnw; + sleep 0.5; + clear; echo "Bidirectional"; stack run ldgv -- interpret < dev-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirectional/client.ldgvnw; + sleep 0.5; + clear; echo "Handoff"; stack run ldgv -- interpret < dev-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff/client.ldgvnw; + sleep 0.5; + # clear; echo "Handoff2"; stack run ldgv -- interpret < dev-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/client.ldgvnw; + # sleep 0.5; + # clear; echo "Bidirhandoff"; stack run ldgv -- interpret < dev-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/client.ldgvnw; + # sleep 0.5; +done \ No newline at end of file diff --git a/testOftenBidirhandoff.sh b/testOftenBidirhandoff.sh new file mode 100644 index 0000000..2c0dcbf --- /dev/null +++ b/testOftenBidirhandoff.sh @@ -0,0 +1,3 @@ +for i in {1..2000}; do + clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/client.ldgvnw & wait); +done \ No newline at end of file diff --git a/testOftenHandoff2.sh b/testOftenHandoff2.sh new file mode 100644 index 0000000..4496b1a --- /dev/null +++ b/testOftenHandoff2.sh @@ -0,0 +1,3 @@ +for i in {1..100}; do + bash testHandoff2.sh; +done \ No newline at end of file diff --git a/testSimple.sh b/testSimple.sh new file mode 100644 index 0000000..9f40056 --- /dev/null +++ b/testSimple.sh @@ -0,0 +1,2 @@ +clear; echo "Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/simple/server.ldgvnw & stack run ldgv -- interpret < dev-examples/simple/client.ldgvnw & wait); +exit; \ No newline at end of file From 9e98bf7e0912b856fb6518c2da54bfc4517b7280 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 23 Jan 2023 13:50:15 +0100 Subject: [PATCH 079/229] Improved sync when sending values --- src/Networking/Client.hs | 11 ++++----- src/Networking/DirectionalConnection.hs | 30 ++++++++++++++++++++----- src/Networking/Messages.hs | 5 +++-- src/Networking/Serialize.hs | 3 ++- src/Networking/Server.hs | 21 +++++++++++------ src/ValueParsing/ValueGrammar.y | 4 +++- src/ValueParsing/ValueTokens.x | 2 ++ 7 files changed, 54 insertions(+), 22 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 6305f69..fac46fb 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -49,13 +49,14 @@ sendValue networkconnection val resendOnError = do valcleaned <- replaceVChan val DC.writeMessage (ncWrite networkconnection) valcleaned -- catch (tryToSend networkconnection hostname port val valcleaned) $ printConErr hostname port - catch (do - tryToSendNetworkMessage networkconnection hostname port (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) valcleaned) resendOnError + catch (do + messagesCount <- DC.countMessages $ ncWrite networkconnection + tryToSendNetworkMessage networkconnection hostname port (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) messagesCount valcleaned) resendOnError sendVChanMessages hostname port val disableVChans val ) $ printConErr hostname port - NCon.Disconnected -> Config.traceIO "Error when sending message: This channel is disconnected" NCon.Emulated -> DC.writeMessage (ncWrite networkconnection) val + _ -> Config.traceIO "Error when sending message: This channel is disconnected" -- MVar.putMVar (ncConnectionState networkconnection) connectionstate sendNetworkMessage :: NetworkConnection Value -> Messages -> Int -> IO () @@ -64,8 +65,8 @@ sendNetworkMessage networkconnection message resendOnError = do case connectionstate of NCon.Connected hostname port -> do catch ( tryToSendNetworkMessage networkconnection hostname port message resendOnError) $ printConErr hostname port - NCon.Disconnected -> Config.traceIO "Error when sending message: This channel is disconnected" NCon.Emulated -> pure () + _ -> Config.traceIO "Error when sending message: This channel is disconnected" --MVar.putMVar (ncConnectionState networkconnection) connectionstate tryToSendNetworkMessage :: NetworkConnection Value -> String -> String -> Messages -> Int -> IO () @@ -215,8 +216,8 @@ closeConnection con = do else do threadDelay 1000000 closeConnection con - NCon.Disconnected -> Config.traceIO "Error when sending message: This channel is disconnected" NCon.Emulated -> pure () + _ -> Config.traceIO "Error when sending message: This channel is disconnected" recieveResponse :: Handle -> IO (Maybe Responses) diff --git a/src/Networking/DirectionalConnection.hs b/src/Networking/DirectionalConnection.hs index f9964b5..86de0fe 100644 --- a/src/Networking/DirectionalConnection.hs +++ b/src/Networking/DirectionalConnection.hs @@ -1,8 +1,8 @@ -module Networking.DirectionalConnection (DirectionalConnection(..), newConnection, createConnection, writeMessage, allMessages, readUnreadMessage, readUnreadMessageMaybe, serializeConnection, syncMessages) where +module Networking.DirectionalConnection (DirectionalConnection(..), newConnection, createConnection, writeMessage, writeMessageIfNext, countMessages, allMessages, readUnreadMessage, readUnreadMessageMaybe, serializeConnection, syncMessages) where import Control.Concurrent.MVar -data DirectionalConnection a = DirectionalConnection { messages :: MVar [a], messagesUnreadStart :: MVar Int} +data DirectionalConnection a = DirectionalConnection { messages :: MVar [a], messagesUnreadStart :: MVar Int, messagesCount :: MVar Int} deriving Eq -- When a channel is duplicated there are no unread messages in the new channel, only the old one @@ -13,7 +13,9 @@ newConnection = do putMVar messages [] messagesUnreadStart <- newEmptyMVar putMVar messagesUnreadStart 0 - return $ DirectionalConnection messages messagesUnreadStart + messagesCount <- newEmptyMVar + putMVar messagesCount 0 + return $ DirectionalConnection messages messagesUnreadStart messagesCount createConnection :: [a] -> Int -> IO (DirectionalConnection a) @@ -22,15 +24,29 @@ createConnection messages unreadStart = do putMVar msg messages messagesUnreadStart <- newEmptyMVar putMVar messagesUnreadStart unreadStart - return $ DirectionalConnection msg messagesUnreadStart + messagesCount <- newEmptyMVar + putMVar messagesCount $ length messages + return $ DirectionalConnection msg messagesUnreadStart messagesCount writeMessage :: DirectionalConnection a -> a -> IO () writeMessage connection message = do - modifyMVar_ (messages connection) (\m -> do - return $ m ++ [message] + modifyMVar_ (messagesCount connection) (\c -> do + modifyMVar_ (messages connection) (\m -> return $ m ++ [message]) + return $ c + 1 ) +writeMessageIfNext :: DirectionalConnection a -> Int -> a -> IO Bool +writeMessageIfNext connection count message = do + modifyMVar (messagesCount connection) (\c -> + if count == c + 1 then do + modifyMVar_ (messages connection) (\m -> return $ m ++ [message]) + return (c + 1, True) + else + return (c, False) + ) + + -- This relies on the message array giving having the same first entrys as the internal messages syncMessages :: DirectionalConnection a -> [a] -> IO () syncMessages connection msgs = do @@ -61,6 +77,8 @@ serializeConnection connection = do messageUnread <- readMVar $ messagesUnreadStart connection return (messageList, messageUnread) +countMessages :: DirectionalConnection a -> IO Int +countMessages connection = readMVar $ messagesCount connection test = do mycon <- newConnection diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs index 00467ce..bc4e974 100644 --- a/src/Networking/Messages.hs +++ b/src/Networking/Messages.hs @@ -14,7 +14,7 @@ data Messages = Introduce UserID | IntroduceClient UserID Port Type | IntroduceServer UserID - | NewValue UserID Value + | NewValue UserID Int Value | SyncIncoming UserID [Value] | RequestSync UserID | ChangePartnerAddress UserID Hostname Port @@ -27,6 +27,7 @@ data Responses | Okay | OkayClose | OkayIntroduce UserID + | OkaySync [Value] | Wait getUserID :: Messages -> String @@ -34,7 +35,7 @@ getUserID = \case Introduce p -> p IntroduceClient p _ _ -> p IntroduceServer p -> p - NewValue p _ -> p + NewValue p _ _ -> p SyncIncoming p _ -> p RequestSync p -> p ChangePartnerAddress p _ _ -> p diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index 1408f6c..f94de8b 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -37,6 +37,7 @@ instance Serializable Responses where Okay -> return "NOkay" OkayClose -> return "NOkayClose" OkayIntroduce u -> serializeLabeledEntry "NOkayIntroduce" u + OkaySync vs -> serializeLabeledEntry "NOkaySync" vs Wait -> return "NWait" instance Serializable Messages where @@ -44,7 +45,7 @@ instance Serializable Messages where Introduce p -> serializeLabeledEntry "NIntroduce" p IntroduceClient p port t -> serializeLabeledEntryMulti "NIntroduceClient" p $ sNext port $ sLast t IntroduceServer p -> serializeLabeledEntry "NIntroduceServer" p - NewValue p v -> serializeLabeledEntryMulti "NNewValue" p $ sLast v + NewValue p c v -> serializeLabeledEntryMulti "NNewValue" p $ sNext c $ sLast v SyncIncoming p vs -> serializeLabeledEntryMulti "NSyncIncoming" p $ sLast vs RequestSync p -> serializeLabeledEntry "NRequestSync" p ChangePartnerAddress p h port -> serializeLabeledEntryMulti "NChangePartnerAddress" p $ sNext h $ sLast port diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 8c4cd89..5d94fc9 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -30,6 +30,8 @@ import qualified Config import qualified Networking.NetworkConnection as NCon import qualified Control.Concurrent as MVar import ProcessEnvironment (ServerSocket) +import qualified Networking.Client as NC +import Control.Monad createServer :: Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), MVar.MVar [(String, Syntax.Type)]) createServer port = do @@ -78,9 +80,8 @@ handleClient mvar clientlist clientsocket hdl ownport message deserialmessages = Config.traceNetIO $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) if redirectRequest then sendRedirect hdl netcon userid else do case deserialmessages of - NewValue userid val -> do - handleNewValue mvar userid val - NC.sendMessage Messages.Okay hdl + NewValue userid count val -> do + handleNewValue mvar userid count val hdl IntroduceClient userid clientport syntype-> do handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype -- Okay message is handled in handle introduce @@ -120,10 +121,13 @@ handleClient mvar clientlist clientsocket hdl ownport message deserialmessages = IntroduceClient userid clientport syntype-> do handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype -- Okay message is handled in handle introduce + IntroduceNewPartnerAddress userid port -> do + NC.sendMessage Messages.Okay hdl + -- We don't know them yet, but should know them as soon as we get the message from the former comm partner _ -> do serial <- NSerialize.serialize deserialmessages Config.traceIO $ "Error unsupported networkmessage: "++ serial - Config.traceIO $ "This is probably a timing issue! Lets resend later" + Config.traceIO "This is probably a timing issue! Lets resend later" NC.sendMessage Messages.Wait hdl Config.traceNetIO $ " Message: " ++ message @@ -150,13 +154,16 @@ sendRedirect handle ncmap userid = do RedirectRequest host port -> NC.sendMessage (Messages.Redirect host port) handle _ -> return () -handleNewValue :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> Value -> IO () -handleNewValue mvar userid val = do +handleNewValue :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> Int -> Value -> Handle -> IO () +handleNewValue mvar userid count val hdl = do networkconnectionmap <- MVar.takeMVar mvar case Map.lookup userid networkconnectionmap of Just networkconnection -> do - ND.writeMessage (ncRead networkconnection) val + success <- ND.writeMessageIfNext (ncRead networkconnection) count val + NC.sendMessage Messages.Okay hdl + unless success $ NC.sendNetworkMessage networkconnection (Messages.RequestSync $ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) 5 Nothing -> do + NC.sendMessage Messages.Okay hdl Config.traceIO "Error during recieving a networkmessage: Introduction is needed prior to sending values!" MVar.putMVar mvar networkconnectionmap diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 1780855..60ed44d 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -128,6 +128,7 @@ import Networking.Messages nrequestclose { T _ T.NRequestClose } nokayclose { T _ T.NOkayClose} nokayintroduce { T _ T.NOkayIntroduce } + nokaysync { T _ T.NOkaySync } nwait { T _ T.NWait} gunit { T _ T.GUnit } @@ -283,7 +284,7 @@ GType : gunit {GUnit} Messages : nintroduce '(' String ')' {Introduce $3} | nintroduceclient '(' String ')' '(' String ')' '(' Type ')' {IntroduceClient $3 $6 $9} | nintroduceserver '(' String ')' {IntroduceServer $3} - | nnewvalue '(' String ')''(' Values ')' {NewValue $3 $6} + | nnewvalue '(' String ')' '(' int ')' '(' Values ')' {NewValue $3 $6 $9} | nsyncincoming '(' String ')''(' SValuesArray ')' {SyncIncoming $3 $6} | nrequestsync '(' String ')' {RequestSync $3} | nchangepartneraddress '(' String ')' '(' String ')' '(' String ')' {ChangePartnerAddress $3 $6 $9} @@ -294,6 +295,7 @@ Responses : nredirect '(' String ')' '(' String ')' {Redirect $3 $6} | nokay {Okay} | nokayclose {OkayClose} | nokayintroduce '(' String ')' {OkayIntroduce $3} + | nokaysync '(' SValuesArray ')' {OkaySync $3} | nwait {Wait} diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index d918483..1babb03 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -141,6 +141,7 @@ tokens :- "NRequestClose" { tok $ const NRequestClose } "NOkayClose" { tok $ const NOkayClose } "NOkayIntroduce" { tok $ const NOkayIntroduce } + "NOkaySync" { tok $ const NOkaySync } "NWait" { tok $ const NWait} Double\:[\-]?[0-9]+[\.][0-9]+ { tok $ Double . read . (drop 7) } @@ -269,6 +270,7 @@ data Token | NRequestClose | NOkayClose | NOkayIntroduce + | NOkaySync | NWait | String String From 2a06d7512e0834dff930a74e41f75ea1850008de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 23 Jan 2023 14:21:52 +0100 Subject: [PATCH 080/229] Improved request sync --- .gitignore | 1 + src/Networking/Client.hs | 16 ++++++++++------ src/Networking/Server.hs | 11 ++++++----- 3 files changed, 17 insertions(+), 11 deletions(-) diff --git a/.gitignore b/.gitignore index 7e73b8e..0f9d592 100644 --- a/.gitignore +++ b/.gitignore @@ -25,3 +25,4 @@ cabal.project.local~ *.swp stack.yaml.lock result +exclude diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index fac46fb..cd91951 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -84,27 +84,31 @@ tryToSendNetworkMessage networkconnection hostname port message resendOnError = forkIO (do Config.traceNetIO $ "Trying to connect to: " ++ hostname ++":"++port addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port - Config.traceNetIO "Trying to open socket" + -- Config.traceNetIO "Trying to open socket" clientsocket <- NC.openSocketNC $ head addrInfo - Config.traceNetIO "Trying to connect" + -- Config.traceNetIO "Trying to connect" -- This sometimes fails connect clientsocket $ addrAddress $ head addrInfo - Config.traceNetIO "Connected" + -- Config.traceNetIO "Connected" handle <- NC.getHandle clientsocket - Config.traceNetIO "Trying to send!" + -- Config.traceNetIO "Trying to send!" NC.sendMessage message handle - Config.traceNetIO "Waiting for response" + -- Config.traceNetIO "Waiting for response" mbyresponse <- recieveResponse handle hClose handle MVar.putMVar response mbyresponse ) mbyresponse <- getResp response 10 - case mbyresponse of Just response -> case response of Okay -> Config.traceNetIO $ "Message okay: "++serializedMessage + OkaySync history -> do + Config.traceNetIO $ "Message okay: "++serializedMessage + serializedResponse <- NSerialize.serialize response + Config.traceNetIO $ "Got syncronization values: "++serializedResponse + DC.syncMessages (ncRead networkconnection) history Redirect host port -> do Config.traceNetIO "Communication partner changed address, resending" NCon.changePartnerAddress networkconnection host port diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 5d94fc9..b7de0a3 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -89,8 +89,8 @@ handleClient mvar clientlist clientsocket hdl ownport message deserialmessages = handleChangePartnerAddress mvar userid hostname port ownport NC.sendMessage Messages.Okay hdl RequestSync userid -> do - handleRequestSync mvar userid - NC.sendMessage Messages.Okay hdl + handleRequestSync mvar userid hdl + -- NC.sendMessage Messages.Okay hdl SyncIncoming userid values -> do handleSyncIncoming mvar userid values NC.sendMessage Messages.Okay hdl @@ -206,13 +206,14 @@ handleChangePartnerAddress mvar userid hostname port ownport = do Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that -handleRequestSync :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> IO () -handleRequestSync mvar userid = do +handleRequestSync :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> Handle -> IO () +handleRequestSync mvar userid hdl = do networkconnectionmap <- MVar.readMVar mvar case Map.lookup userid networkconnectionmap of Just networkconnection -> do -- Change to current network address writevals <- ND.allMessages $ ncWrite networkconnection - NClient.sendNetworkMessage networkconnection (SyncIncoming (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) writevals) 5 + NC.sendMessage (Messages.OkaySync writevals) hdl + -- NClient.sendNetworkMessage networkconnection (SyncIncoming (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) writevals) 5 othing -> return () handleSyncIncoming :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> [Value] -> IO () From 2b6c22cfdaa519033ba1379d3b0f8fe434eddd5a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 23 Jan 2023 16:37:35 +0100 Subject: [PATCH 081/229] Threaded receiving messages experimental --- src/Networking/Client.hs | 24 +++++++++++++++++------- src/Networking/Server.hs | 6 ++++-- 2 files changed, 21 insertions(+), 9 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index cd91951..307ba6c 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -80,8 +80,10 @@ tryToSendNetworkMessage networkconnection hostname port message resendOnError = , addrFlags = [] , addrSocketType = Stream } + connectionsuccessful <- MVar.newEmptyMVar + MVar.putMVar connectionsuccessful False response <- MVar.newEmptyMVar - forkIO (do + threadid <- forkIO (do Config.traceNetIO $ "Trying to connect to: " ++ hostname ++":"++port addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port -- Config.traceNetIO "Trying to open socket" @@ -89,6 +91,8 @@ tryToSendNetworkMessage networkconnection hostname port message resendOnError = -- Config.traceNetIO "Trying to connect" -- This sometimes fails connect clientsocket $ addrAddress $ head addrInfo + _ <- MVar.takeMVar connectionsuccessful + MVar.putMVar connectionsuccessful True -- Config.traceNetIO "Connected" handle <- NC.getHandle clientsocket -- Config.traceNetIO "Trying to send!" @@ -99,7 +103,7 @@ tryToSendNetworkMessage networkconnection hostname port message resendOnError = hClose handle MVar.putMVar response mbyresponse ) - mbyresponse <- getResp response 10 + mbyresponse <- getResp threadid connectionsuccessful response 10 case mbyresponse of Just response -> case response of @@ -115,7 +119,7 @@ tryToSendNetworkMessage networkconnection hostname port message resendOnError = tryToSendNetworkMessage networkconnection host port message resendOnError Wait -> do Config.traceNetIO "Communication out of sync lets wait!" - threadDelay 1000000 + threadDelay 100000 tryToSendNetworkMessage networkconnection hostname port message resendOnError _ -> Config.traceNetIO "Unknown communication error" @@ -130,14 +134,20 @@ tryToSendNetworkMessage networkconnection hostname port message resendOnError = _ -> Config.traceNetIO "Error when sending message: This channel is disconnected while sending" where - getResp mvar count = do - res <- tryTakeMVar mvar + getResp :: ThreadId -> MVar.MVar Bool -> MVar.MVar (Maybe Responses) -> Int -> IO (Maybe Responses) + getResp threadid connectedmvar mbyResponse count = do + res <- tryTakeMVar mbyResponse case res of Just response -> return response Nothing -> if count /= 0 then do threadDelay 100000 - getResp mvar (count-1) - else return Nothing + connected <- MVar.readMVar connectedmvar + if connected then getResp threadid connectedmvar mbyResponse (count-1) else do + killThread threadid + return Nothing + else do + killThread threadid + return Nothing printConErr :: String -> String -> IOException -> IO () diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index b7de0a3..aa8ab7c 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -66,8 +66,10 @@ acceptClients mvar clientlist socket ownport = do acceptClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> String -> IO () acceptClient mvar clientlist clientsocket ownport = do hdl <- NC.getHandle $ fst clientsocket - NC.recieveMessage hdl VG.parseMessages (\_ -> return ()) $ handleClient mvar clientlist clientsocket hdl ownport - hClose hdl + NC.recieveMessage hdl VG.parseMessages (\_ -> hClose hdl) (\msg des -> void $ forkIO ( do + handleClient mvar clientlist clientsocket hdl ownport msg des + hClose hdl + )) handleClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Messages -> IO () handleClient mvar clientlist clientsocket hdl ownport message deserialmessages = do From 4d0b787d591530ae652ec92826b4cd2a6a03ce2e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 24 Jan 2023 10:59:04 +0100 Subject: [PATCH 082/229] Seems to be rather stable without end now --- .gitignore | 1 + src/Interpreter.hs | 2 +- src/Networking/Client.hs | 22 +++--- src/Networking/Common.hs | 6 +- src/Networking/NetworkConnection.hs | 4 +- src/Networking/Server.hs | 103 +++++++++++++++++++++++----- 6 files changed, 107 insertions(+), 31 deletions(-) diff --git a/.gitignore b/.gitignore index 0f9d592..d615e00 100644 --- a/.gitignore +++ b/.gitignore @@ -26,3 +26,4 @@ cabal.project.local~ stack.yaml.lock result exclude +result* diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 78c2881..0024582 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -304,7 +304,7 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) interpretApp _ (VSend v@(VChan cc _ usedmvar)) w = do used <- liftIO $ MVar.readMVar usedmvar if used then throw $ VChanIsUsedException $ show v else do - liftIO $ NClient.sendValue cc w (10) + liftIO $ NClient.sendValue cc w (-1) -- Disable old VChan newV <- liftIO $ disableOldVChan v diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 307ba6c..709bfa4 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -46,13 +46,13 @@ sendValue networkconnection val resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port -> do + sendVChanMessages hostname port val valcleaned <- replaceVChan val DC.writeMessage (ncWrite networkconnection) valcleaned + messagesCount <- DC.countMessages $ ncWrite networkconnection -- catch (tryToSend networkconnection hostname port val valcleaned) $ printConErr hostname port catch (do - messagesCount <- DC.countMessages $ ncWrite networkconnection tryToSendNetworkMessage networkconnection hostname port (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) messagesCount valcleaned) resendOnError - sendVChanMessages hostname port val disableVChans val ) $ printConErr hostname port NCon.Emulated -> DC.writeMessage (ncWrite networkconnection) val @@ -119,17 +119,21 @@ tryToSendNetworkMessage networkconnection hostname port message resendOnError = tryToSendNetworkMessage networkconnection host port message resendOnError Wait -> do Config.traceNetIO "Communication out of sync lets wait!" - threadDelay 100000 + threadDelay 1000000 tryToSendNetworkMessage networkconnection hostname port message resendOnError _ -> Config.traceNetIO "Unknown communication error" Nothing -> do Config.traceNetIO "Error when recieving response" connectionstate <- MVar.readMVar $ ncConnectionState networkconnection + connectedToPeer <- MVar.readMVar connectionsuccessful + unless connectedToPeer $ Config.traceNetIO "Not connected to peer" + Config.traceNetIO $ "Original message: " ++ serializedMessage case connectionstate of - NCon.Connected newhostname newport -> if resendOnError /= 0 then do + NCon.Connected newhostname newport -> if resendOnError /= 0 && connectedToPeer then do Config.traceNetIO $ "Old communication partner offline! New communication partner: " ++ newhostname ++ ":" ++ newport - tryToSendNetworkMessage networkconnection newhostname newport message (resendOnError-1) + threadDelay 1000000 + tryToSendNetworkMessage networkconnection newhostname newport message $ max (resendOnError-1) (-1) else Config.traceNetIO "Old communication partner offline! No longer retrying" _ -> Config.traceNetIO "Error when sending message: This channel is disconnected while sending" @@ -142,7 +146,7 @@ tryToSendNetworkMessage networkconnection hostname port message resendOnError = Nothing -> if count /= 0 then do threadDelay 100000 connected <- MVar.readMVar connectedmvar - if connected then getResp threadid connectedmvar mbyResponse (count-1) else do + if connected then getResp threadid connectedmvar mbyResponse $ max (count-1) (-1) else do killThread threadid return Nothing else do @@ -197,9 +201,9 @@ sendVChanMessages newhost newport input = case input of oldconnectionstate <- MVar.takeMVar $ ncConnectionState nc - MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest newhost newport - tempnetcon <- NCon.newNetworkConnectionAllowingMaybe (NCon.ncPartnerUserID nc) (NCon.ncOwnUserID nc) (NCon.csHostname oldconnectionstate) (NCon.csPort oldconnectionstate) - sendNetworkMessage tempnetcon (Messages.ChangePartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID nc) newhost newport) 5 + MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest (NCon.csHostname oldconnectionstate) (NCon.csPort oldconnectionstate) newhost newport + -- tempnetcon <- NCon.newNetworkConnectionAllowingMaybe (NCon.ncPartnerUserID nc) (NCon.ncOwnUserID nc) (NCon.csHostname oldconnectionstate) (NCon.csPort oldconnectionstate) + -- sendNetworkMessage tempnetcon (Messages.ChangePartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID nc) newhost newport) 5 Config.traceNetIO $ "Set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport _ -> return () where diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 7fd3512..8b7c9a1 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -26,9 +26,11 @@ recieveMessage handle grammar fallbackResponse messageHandler = do message <- hGetLine handle case VT.runAlex message grammar of Left err -> do - Config.traceIO $ "Error during recieving a networkmessage: "++err + Config.traceNetIO $ "Error during recieving a networkmessage: "++err fallbackResponse message - Right deserialmessage -> messageHandler message deserialmessage + Right deserialmessage -> do + Config.traceNetIO $ "New superficially valid message recieved: "++message + messageHandler message deserialmessage openSocketNC :: AddrInfo -> IO Socket openSocketNC addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) \ No newline at end of file diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index ac09d8a..cdb4261 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -10,7 +10,7 @@ data NetworkConnection a = NetworkConnection {ncRead :: DirectionalConnection a, data ConnectionState = Connected {csHostname :: String, csPort :: String} | Disconnected | Emulated - | RedirectRequest {csHostname :: String, csPort :: String} -- Asks to redirect to this connection + | RedirectRequest {csHostname :: String, csPort :: String, csRedirectHostname :: String, csRedirectPort :: String} -- Asks to redirect to this connection deriving (Eq, Show) @@ -65,7 +65,7 @@ serializeNetworkConnection nc = do (writeList, writeUnread) <- serializeConnection $ ncWrite nc (address, port) <- case constate of Connected address port -> return (address, port) - RedirectRequest address port -> return (address, port) + RedirectRequest address port _ _-> return (address, port) _ -> return ("", "") return (readList, readUnread, writeList, writeUnread, Data.Maybe.fromMaybe "" $ ncPartnerUserID nc, Data.Maybe.fromMaybe "" $ ncOwnUserID nc, address, port) diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index aa8ab7c..eacfe42 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -45,7 +45,7 @@ createServer port = do } addrInfo <- getAddrInfo (Just hints) Nothing $ Just $ show port bind sock $ addrAddress $ head addrInfo - listen sock 2 + listen sock 1024 mvar <- MVar.newEmptyMVar MVar.putMVar mvar Map.empty clientlist <- MVar.newEmptyMVar @@ -66,24 +66,31 @@ acceptClients mvar clientlist socket ownport = do acceptClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> String -> IO () acceptClient mvar clientlist clientsocket ownport = do hdl <- NC.getHandle $ fst clientsocket - NC.recieveMessage hdl VG.parseMessages (\_ -> hClose hdl) (\msg des -> void $ forkIO ( do - handleClient mvar clientlist clientsocket hdl ownport msg des - hClose hdl - )) + -- NC.recieveMessage hdl VG.parseMessages (\_ -> hClose hdl) (\msg des -> void $ forkIO ( do + -- handleClient mvar clientlist clientsocket hdl ownport msg des + -- hClose hdl + -- )) + NC.recieveMessage hdl VG.parseMessages (\_ -> return ()) $ handleClient mvar clientlist clientsocket hdl ownport + hClose hdl handleClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Messages -> IO () handleClient mvar clientlist clientsocket hdl ownport message deserialmessages = do let userid = getUserID deserialmessages + Config.traceNetIO $ show ownport ++ " Entering redirect handler for message: "++ message netcon <- MVar.takeMVar mvar + Config.traceNetIO $ show ownport ++ " Entered redirect handler for message: "++ message redirectRequest <- checkRedirectRequest netcon userid + Config.traceNetIO $ show ownport ++ " Redirect request" ++ show redirectRequest + Config.traceNetIO $ show ownport ++ " Leaving redirect handler for message: " ++ message MVar.putMVar mvar netcon + Config.traceNetIO $ show ownport ++ " Left redirect handler for message: " ++ message case Map.lookup userid netcon of Just networkcon -> do - Config.traceNetIO $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) + Config.traceNetIO $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " (" ++ ownport ++ ") from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) if redirectRequest then sendRedirect hdl netcon userid else do case deserialmessages of NewValue userid count val -> do - handleNewValue mvar userid count val hdl + handleNewValue mvar userid count val ownport hdl IntroduceClient userid clientport syntype-> do handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype -- Okay message is handled in handle introduce @@ -101,11 +108,15 @@ handleClient mvar clientlist clientsocket hdl ownport message deserialmessages = NC.sendMessage Messages.Okay hdl IntroduceNewPartnerAddress userid port -> do networkconnectionmap <- MVar.takeMVar mvar + Config.traceNetIO $ "Took MVar for message: " ++ message case Map.lookup userid networkconnectionmap of Just networkconnection -> do -- Change to current network address case snd clientsocket of - SockAddrInet _ hostname -> NCon.changePartnerAddress networkconnection (hostaddressTypeToString hostname) port + SockAddrInet _ hostname -> do + Config.traceNetIO $ "Trying to change the address to: " ++ hostaddressTypeToString hostname ++ ":" ++ port + NCon.changePartnerAddress networkconnection (hostaddressTypeToString hostname) port _ -> return () + Config.traceNetIO $ "Put MVar for message: " ++ message MVar.putMVar mvar networkconnectionmap -- For some reason constate doesn't seem to properly apply MVar.putMVar mvar networkconnectionmap @@ -124,7 +135,8 @@ handleClient mvar clientlist clientsocket hdl ownport message deserialmessages = handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype -- Okay message is handled in handle introduce IntroduceNewPartnerAddress userid port -> do - NC.sendMessage Messages.Okay hdl + -- NC.sendMessage Messages.Okay hdl + NC.sendMessage Messages.Wait hdl -- We don't know them yet, but should know them as soon as we get the message from the former comm partner _ -> do serial <- NSerialize.serialize deserialmessages @@ -143,7 +155,7 @@ checkRedirectRequest ncmap userid = do Just networkconnection -> do constate <- MVar.readMVar $ ncConnectionState networkconnection case constate of - RedirectRequest _ _ -> return True + RedirectRequest {} -> return True _ -> return False sendRedirect :: Handle -> Map.Map String (NetworkConnection Value) -> String -> IO () @@ -153,21 +165,78 @@ sendRedirect handle ncmap userid = do Just networkconnection -> do constate <- MVar.readMVar $ ncConnectionState networkconnection case constate of - RedirectRequest host port -> NC.sendMessage (Messages.Redirect host port) handle + RedirectRequest _ _ host port -> do + Config.traceNetIO $ "Send redirect to:" ++ host ++ ":" ++ port + NC.sendMessage (Messages.Redirect host port) handle _ -> return () -handleNewValue :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> Int -> Value -> Handle -> IO () -handleNewValue mvar userid count val hdl = do - networkconnectionmap <- MVar.takeMVar mvar +handleNewValue :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> Int -> Value -> String -> Handle -> IO () +handleNewValue mvar userid count val ownport hdl = do + -- networkconnectionmap <- MVar.takeMVar mvar + networkconnectionmap <- MVar.readMVar mvar + Config.traceNetIO $ show ownport ++ " Entered NewValue handler" case Map.lookup userid networkconnectionmap of Just networkconnection -> do + Config.traceNetIO $ show ownport ++ " Reading message" success <- ND.writeMessageIfNext (ncRead networkconnection) count val + if success then Config.traceNetIO $ show ownport ++ " Message valid" else Config.traceNetIO $ show ownport ++ " Message invalid" + unless success $ NC.sendNetworkMessage networkconnection (Messages.RequestSync $ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) (-1) + Config.traceNetIO $ show ownport ++ " Contacting peers" + contactNewPeers val ownport + Config.traceNetIO $ show ownport ++ " Contacted peers" NC.sendMessage Messages.Okay hdl - unless success $ NC.sendNetworkMessage networkconnection (Messages.RequestSync $ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) 5 Nothing -> do NC.sendMessage Messages.Okay hdl - Config.traceIO "Error during recieving a networkmessage: Introduction is needed prior to sending values!" - MVar.putMVar mvar networkconnectionmap + Config.traceNetIO "Error during recieving a networkmessage: Introduction is needed prior to sending values!" + Config.traceNetIO $ show ownport ++ " Leaving NewValue handler" + -- MVar.putMVar mvar networkconnectionmap + +contactNewPeers :: Value -> String -> IO () +contactNewPeers input ownport = case input of + VSend v -> do + nv <- contactNewPeers v ownport + -- return $ VSend nv + return () + VPair v1 v2 -> do + nv1 <- contactNewPeers v1 ownport + nv2 <- contactNewPeers v2 ownport + -- return $ VPair nv1 nv2 + return () + VFunc penv a b -> do + newpenv <- contactNewPeersPEnv penv ownport + -- return $ VFunc newpenv a b + return () + VDynCast v g -> do + nv <- contactNewPeers v ownport + -- return $ VDynCast nv g + return () + VFuncCast v a b -> do + nv <- contactNewPeers v ownport + -- return $ VFuncCast nv a b + return () + VRec penv a b c d -> do + newpenv <- contactNewPeersPEnv penv ownport + -- return $ VRec newpenv a b c d + return () + VNewNatRec penv a b c d e f g -> do + newpenv <- contactNewPeersPEnv penv ownport + -- return $ VNewNatRec newpenv a b c d e f g + return () + VChanSerial r w p o c -> do + let (hostname, port) = c + tempNC <- newNetworkConnection p o hostname port + NClient.sendNetworkMessage tempNC (Messages.IntroduceNewPartnerAddress o ownport) 5 + _ -> return () -- return input + where + contactNewPeersPEnv :: [(String, Value)] -> String -> IO () -- [(String, Value)] + contactNewPeersPEnv [] _ = return () --return [] + contactNewPeersPEnv (x:xs) ownport = do + newval <- contactNewPeers (snd x) ownport + rest <- contactNewPeersPEnv xs ownport + -- return $ (fst x, newval):rest + return () + + handleIntroduceClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Syntax.Type -> IO () handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype = do From 131904580168a3ece1c4fdde1da253ea3865526e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 24 Jan 2023 11:15:16 +0100 Subject: [PATCH 083/229] Removed Console spam --- src/Networking/Common.hs | 2 +- src/Networking/Server.hs | 22 +++++++++++----------- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 8b7c9a1..b5becef 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -29,7 +29,7 @@ recieveMessage handle grammar fallbackResponse messageHandler = do Config.traceNetIO $ "Error during recieving a networkmessage: "++err fallbackResponse message Right deserialmessage -> do - Config.traceNetIO $ "New superficially valid message recieved: "++message + -- Config.traceNetIO $ "New superficially valid message recieved: "++message messageHandler message deserialmessage openSocketNC :: AddrInfo -> IO Socket diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index eacfe42..91fd19d 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -76,14 +76,14 @@ acceptClient mvar clientlist clientsocket ownport = do handleClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Messages -> IO () handleClient mvar clientlist clientsocket hdl ownport message deserialmessages = do let userid = getUserID deserialmessages - Config.traceNetIO $ show ownport ++ " Entering redirect handler for message: "++ message + -- Config.traceNetIO $ show ownport ++ " Entering redirect handler for message: "++ message netcon <- MVar.takeMVar mvar - Config.traceNetIO $ show ownport ++ " Entered redirect handler for message: "++ message + -- Config.traceNetIO $ show ownport ++ " Entered redirect handler for message: "++ message redirectRequest <- checkRedirectRequest netcon userid - Config.traceNetIO $ show ownport ++ " Redirect request" ++ show redirectRequest - Config.traceNetIO $ show ownport ++ " Leaving redirect handler for message: " ++ message + -- Config.traceNetIO $ show ownport ++ " Redirect request" ++ show redirectRequest + -- Config.traceNetIO $ show ownport ++ " Leaving redirect handler for message: " ++ message MVar.putMVar mvar netcon - Config.traceNetIO $ show ownport ++ " Left redirect handler for message: " ++ message + -- Config.traceNetIO $ show ownport ++ " Left redirect handler for message: " ++ message case Map.lookup userid netcon of Just networkcon -> do Config.traceNetIO $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " (" ++ ownport ++ ") from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) @@ -174,21 +174,21 @@ handleNewValue :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String handleNewValue mvar userid count val ownport hdl = do -- networkconnectionmap <- MVar.takeMVar mvar networkconnectionmap <- MVar.readMVar mvar - Config.traceNetIO $ show ownport ++ " Entered NewValue handler" + -- Config.traceNetIO $ show ownport ++ " Entered NewValue handler" case Map.lookup userid networkconnectionmap of Just networkconnection -> do - Config.traceNetIO $ show ownport ++ " Reading message" + -- Config.traceNetIO $ show ownport ++ " Reading message" success <- ND.writeMessageIfNext (ncRead networkconnection) count val - if success then Config.traceNetIO $ show ownport ++ " Message valid" else Config.traceNetIO $ show ownport ++ " Message invalid" + -- if success then Config.traceNetIO $ show ownport ++ " Message valid" else Config.traceNetIO $ show ownport ++ " Message invalid" unless success $ NC.sendNetworkMessage networkconnection (Messages.RequestSync $ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) (-1) - Config.traceNetIO $ show ownport ++ " Contacting peers" + -- Config.traceNetIO $ show ownport ++ " Contacting peers" contactNewPeers val ownport - Config.traceNetIO $ show ownport ++ " Contacted peers" + -- Config.traceNetIO $ show ownport ++ " Contacted peers" NC.sendMessage Messages.Okay hdl Nothing -> do NC.sendMessage Messages.Okay hdl Config.traceNetIO "Error during recieving a networkmessage: Introduction is needed prior to sending values!" - Config.traceNetIO $ show ownport ++ " Leaving NewValue handler" + -- Config.traceNetIO $ show ownport ++ " Leaving NewValue handler" -- MVar.putMVar mvar networkconnectionmap contactNewPeers :: Value -> String -> IO () From 5ea6d5967d8f71800a323ba103d84526f809c194 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 24 Jan 2023 11:36:15 +0100 Subject: [PATCH 084/229] Seems to run stable enough without end command now --- dev-examples/add/client.ldgvnw | 4 ++-- dev-examples/add/server.ldgvnw | 4 ++-- dev-examples/bidirectional/client.ldgvnw | 4 ++-- dev-examples/bidirectional/server.ldgvnw | 4 ++-- dev-examples/handoff2/client.ldgvnw | 4 ++-- dev-examples/handoff2/handoff.ldgvnw | 4 ++-- dev-examples/handoff2/server.ldgvnw | 4 ++-- dev-examples/simple/client.ldgvnw | 2 +- dev-examples/simple/server.ldgvnw | 4 ++-- 9 files changed, 17 insertions(+), 17 deletions(-) diff --git a/dev-examples/add/client.ldgvnw b/dev-examples/add/client.ldgvnw index 6c98496..5fccada 100644 --- a/dev-examples/add/client.ldgvnw +++ b/dev-examples/add/client.ldgvnw @@ -6,13 +6,13 @@ type SendInt : ! ~ssn = !Int. !Int. Unit val send2 (c: SendInt) = let x = ((send c) 1) in let y = ((send x) 42) in - let z = end y in + -- let z = end y in () val add2 (c1: dualof SendInt) = let = recv c1 in let = recv c2 in - let c4 = end c3 in + -- let c4 = end c3 in (m + n) val main : Unit diff --git a/dev-examples/add/server.ldgvnw b/dev-examples/add/server.ldgvnw index 66b4476..fdb5e13 100644 --- a/dev-examples/add/server.ldgvnw +++ b/dev-examples/add/server.ldgvnw @@ -6,13 +6,13 @@ type SendInt : ! ~ssn = !Int. !Int. Unit val send2 (c: SendInt) = let x = ((send c) 1) in let y = ((send x) 42) in - let z = end y in + -- let z = end y in () val add2 (c1: dualof SendInt) = let = recv c1 in let = recv c2 in - let c4 = end c3 in + -- let c4 = end c3 in (m + n) diff --git a/dev-examples/bidirectional/client.ldgvnw b/dev-examples/bidirectional/client.ldgvnw index 76574e4..a68a0a7 100644 --- a/dev-examples/bidirectional/client.ldgvnw +++ b/dev-examples/bidirectional/client.ldgvnw @@ -8,7 +8,7 @@ val send2 (c: SendInt) = let = recv x in let y = ((send x2) 41) in let = recv y in - let y3 = end y2 in + -- let y3 = end y2 in (m + n) val add2 (c1: dualof SendInt) = @@ -16,7 +16,7 @@ val add2 (c1: dualof SendInt) = let c22 = (send c2) 1300 in let = recv c22 in let c32 = (send c3) 37 in - let c4 = end c32 in + -- let c4 = end c32 in (m + n) val main : Int diff --git a/dev-examples/bidirectional/server.ldgvnw b/dev-examples/bidirectional/server.ldgvnw index 0b99ba3..65dd284 100644 --- a/dev-examples/bidirectional/server.ldgvnw +++ b/dev-examples/bidirectional/server.ldgvnw @@ -8,7 +8,7 @@ val send2 (c: SendInt) = let = recv x in let y = ((send x2) 41) in let = recv y in - let y3 = end y2 in + -- let y3 = end y2 in (m + n) val add2 (c1: dualof SendInt) = @@ -16,7 +16,7 @@ val add2 (c1: dualof SendInt) = let c22 = (send c2) 1300 in let = recv c22 in let c32 = (send c3) 37 in - let c4 = end c32 in + -- let c4 = end c32 in (m + n) val main : Int diff --git a/dev-examples/handoff2/client.ldgvnw b/dev-examples/handoff2/client.ldgvnw index 1e0d29a..45c3aa7 100644 --- a/dev-examples/handoff2/client.ldgvnw +++ b/dev-examples/handoff2/client.ldgvnw @@ -6,13 +6,13 @@ type SendInt : ! ~ssn = !Int. !Int. Unit val send2 (c: SendInt) = let x = ((send c) 1) in let y = ((send x) 42) in - let z = end y in + -- let z = end y in () val add2 (c1: dualof SendInt) = let = recv c1 in let = recv c2 in - let c4 = end c3 in + -- let c4 = end c3 in (m + n) val main : Unit diff --git a/dev-examples/handoff2/handoff.ldgvnw b/dev-examples/handoff2/handoff.ldgvnw index 9d0ecfa..4961512 100644 --- a/dev-examples/handoff2/handoff.ldgvnw +++ b/dev-examples/handoff2/handoff.ldgvnw @@ -12,7 +12,7 @@ val main = let con = (connect sock (dualof SendSendOneInt) "127.0.0.1" 4242) in let = recv con in let = recv oneint in - let c4 = end c2 in - let c5 = end c3 in + -- let c4 = end c2 in + -- let c5 = end c3 in result diff --git a/dev-examples/handoff2/server.ldgvnw b/dev-examples/handoff2/server.ldgvnw index 4fe7c9d..9d9429e 100644 --- a/dev-examples/handoff2/server.ldgvnw +++ b/dev-examples/handoff2/server.ldgvnw @@ -9,13 +9,13 @@ type SendSendOneInt : ! ~ssn = !SendOneInt. Unit val send2 (c: SendInt) = let x = ((send c) 1) in let y = ((send x) 42) in - let z = end y in + -- let z = end y in () val add2 (c1: dualof SendInt) (c3: SendSendOneInt)= let = recv c1 in let y = ((send c3) c2) in - let z = end y in + -- let z = end y in (m) -- Hier problematisch ldgv hat noch kein Konzept wie beim akzeptieren zwischen verschiedenen Types ungerschieden werden kann diff --git a/dev-examples/simple/client.ldgvnw b/dev-examples/simple/client.ldgvnw index ada14e4..67e9412 100644 --- a/dev-examples/simple/client.ldgvnw +++ b/dev-examples/simple/client.ldgvnw @@ -19,7 +19,7 @@ val lClient (d : TClient) (x : Int) : Int = let d2 = (send d1) x in let = recv d2 in let = recv d3 in - let zzz = end zz in + -- let zzz = end zz in r type TServer : ! ~ssn = diff --git a/dev-examples/simple/server.ldgvnw b/dev-examples/simple/server.ldgvnw index d64be4d..afc1ca4 100644 --- a/dev-examples/simple/server.ldgvnw +++ b/dev-examples/simple/server.ldgvnw @@ -19,7 +19,7 @@ val lClient (d : TClient) (x : Int) : Int = let d2 = (send d1) x in let = recv d2 in let = recv d3 in - let zzz = end zz in + -- let zzz = end zz in r type TServer : ! ~ssn = @@ -47,5 +47,5 @@ val main = let sock = 4242 in let con = (accept sock (dualof TClient)) in let e = lServer con in - let ee = end e in + -- let ee = end e in () From 55a3b9c657557ac01c0af3ddbb1182c4b10d0a22 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 24 Jan 2023 18:05:11 +0100 Subject: [PATCH 085/229] Added code that should be later useful for fast networking --- src/Config.hs | 9 ++++++++- src/Interpreter.hs | 30 ++++++++++++++++-------------- src/Networking/Client.hs | 4 ++-- src/Networking/Messages.hs | 5 +++++ src/Networking/Serialize.hs | 5 +++++ src/ProcessEnvironment.hs | 7 ++++++- src/ValueParsing/ValueGrammar.y | 6 ++++++ src/ValueParsing/ValueTokens.x | 4 ++++ test/Utils.hs | 29 +++++++++++++++++++++-------- testNWCount.sh | 2 +- 10 files changed, 74 insertions(+), 27 deletions(-) diff --git a/src/Config.hs b/src/Config.hs index bb9abba..df72d9c 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -11,12 +11,19 @@ selected ident = ident `elem` ["valueEquiv", "subtype"] data DebugLevel = DebugNone | DebugNetwork | DebugAll deriving (Eq, Ord, Show) - debugLevel :: DebugLevel --debugLevel = DebugAll debugLevel = DebugNetwork --debugLevel = DebugNone + +data NetworkingMethod = NetworkingStateless | NetworkingFast + deriving (Eq, Ord, Show) + +networkingMethod :: NetworkingMethod +networkingMethod = NetworkingStateless + + trace :: String -> a -> a trace s a | debugLevel > DebugNetwork = D.trace s a | otherwise = a diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 0024582..5d27fc7 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -95,8 +95,10 @@ blame exp = throw $ CastException exp interpret :: [Decl] -> IO Value interpret decls = do sockets <- MVar.newEmptyMVar + handles <- MVar.newEmptyMVar MVar.putMVar sockets Map.empty - R.runReaderT (interpretDecl decls) ([], sockets) + MVar.putMVar handles Map.empty + R.runReaderT (interpretDecl decls) ([], (sockets, handles)) interpretDecl :: [Decl] -> InterpretM Value interpretDecl (DFun "main" _ e _:_) = interpret' e @@ -151,8 +153,8 @@ eval = \case case v of VPair {} -> do C.traceIO $ "Interpreting pair cast expression: Value(" ++ show v ++ ") NFType(" ++ show nft1 ++ ") NFType(" ++ show nft2 ++ ")" - (env, sockets) <- ask - v' <- lift $ reducePairCast sockets v (toNFPair nft1) (toNFPair nft2) + (env, (sockets, handles)) <- ask + v' <- lift $ reducePairCast sockets handles v (toNFPair nft1) (toNFPair nft2) maybe (blame cast) return v' _ -> let v' = reduceCast v nft1 nft2 in maybe (blame cast) return v' Var s -> ask >>= \(env, _) -> maybe (throw $ LookupException s) (liftIO . pure) (lookup s env) @@ -231,7 +233,7 @@ eval = \case val <- interpret' e case val of VInt port -> do - (env, sockets) <- ask + (env, (sockets, handles)) <- ask (mvar, clientlist, ownport) <- liftIO $ NS.ensureSocket port sockets -- newuser <- liftIO $ Chan.readChan chan liftIO $ C.traceIO "Searching for correct communicationpartner" @@ -255,7 +257,7 @@ eval = \case val <- interpret' e0 case val of VInt port -> do - (env, sockets) <- ask + (env, (sockets, handles)) <- ask (networkconmapmvar, chan, ownport) <- liftIO $ NS.ensureSocket port sockets addressVal <- interpret' e1 case addressVal of @@ -412,21 +414,21 @@ toNFPair :: NFType -> NFType toNFPair (NFGType (GPair)) = NFPair (FuncType [] "x" TDyn TDyn) toNFPair t = t -reducePairCast :: MVar.MVar (Map.Map Int ServerSocket) -> Value -> NFType -> NFType -> IO (Maybe Value) -reducePairCast sockets (VPair v w) (NFPair (FuncType penv s t1 t2)) (NFPair (FuncType penv' s' t1' t2')) = do - mv' <- reduceComponent sockets v (penv, t1) (penv', t1') +reducePairCast :: MVar.MVar (Map.Map Int ServerSocket) -> MVar.MVar ActiveConnections -> Value -> NFType -> NFType -> IO (Maybe Value) +reducePairCast sockets handles (VPair v w) (NFPair (FuncType penv s t1 t2)) (NFPair (FuncType penv' s' t1' t2')) = do + mv' <- reduceComponent sockets handles v (penv, t1) (penv', t1') case mv' of Nothing -> return Nothing Just v' -> do - mw' <- reduceComponent sockets w ((s, v) : penv, t2) ((s', v') : penv', t2') + mw' <- reduceComponent sockets handles w ((s, v) : penv, t2) ((s', v') : penv', t2') return $ liftM2 VPair mv' mw' where - reduceComponent :: MVar.MVar (Map.Map Int ServerSocket) -> Value -> (PEnv, Type) -> (PEnv, Type) -> IO (Maybe Value) - reduceComponent sockets v (penv, t) (penv', t') = do - nft <- R.runReaderT (evalType t) (penv, sockets) - nft' <- R.runReaderT (evalType t') (penv', sockets) + reduceComponent :: MVar.MVar (Map.Map Int ServerSocket) -> MVar.MVar ActiveConnections -> Value -> (PEnv, Type) -> (PEnv, Type) -> IO (Maybe Value) + reduceComponent sockets handles v (penv, t) (penv', t') = do + nft <- R.runReaderT (evalType t) (penv, (sockets, handles)) + nft' <- R.runReaderT (evalType t') (penv', (sockets, handles)) return $ reduceCast v nft nft' -reducePairCast _ _ _ _ = return Nothing +reducePairCast _ _ _ _ _ = return Nothing equalsType :: NFType -> GType -> Bool equalsType (NFFunc (FuncType _ _ TDyn TDyn)) (GFunc _) = True diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 709bfa4..f1eb0e7 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -56,7 +56,7 @@ sendValue networkconnection val resendOnError = do disableVChans val ) $ printConErr hostname port NCon.Emulated -> DC.writeMessage (ncWrite networkconnection) val - _ -> Config.traceIO "Error when sending message: This channel is disconnected" + _ -> Config.traceNetIO "Error when sending message: This channel is disconnected" -- MVar.putMVar (ncConnectionState networkconnection) connectionstate sendNetworkMessage :: NetworkConnection Value -> Messages -> Int -> IO () @@ -66,7 +66,7 @@ sendNetworkMessage networkconnection message resendOnError = do NCon.Connected hostname port -> do catch ( tryToSendNetworkMessage networkconnection hostname port message resendOnError) $ printConErr hostname port NCon.Emulated -> pure () - _ -> Config.traceIO "Error when sending message: This channel is disconnected" + _ -> Config.traceNetIO "Error when sending message: This channel is disconnected" --MVar.putMVar (ncConnectionState networkconnection) connectionstate tryToSendNetworkMessage :: NetworkConnection Value -> String -> String -> Messages -> Int -> IO () diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs index bc4e974..43f9047 100644 --- a/src/Networking/Messages.hs +++ b/src/Networking/Messages.hs @@ -8,6 +8,7 @@ import Syntax type UserID = String type Hostname = String type Port = String +type ConversationID = String -- I need to add the Port to every introduction so I can answer oder alles muss mit einem okay quitiert werden, dann kann die antwort gesendet werden data Messages @@ -30,6 +31,10 @@ data Responses | OkaySync [Value] | Wait +data ConversationSession + = ConversationMessage ConversationID Messages + | ConversationResponse ConversationID Responses + getUserID :: Messages -> String getUserID = \case Introduce p -> p diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index f94de8b..b7562c2 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -31,6 +31,11 @@ class Serializable a where serialize :: a -> IO String +instance Serializable ConversationSession where + serialize = \case + ConversationMessage c m -> serializeLabeledEntryMulti "NConversationMessage" c $ sLast m + ConversationResponse c r -> serializeLabeledEntryMulti "NConversationResponse" c $ sLast r + instance Serializable Responses where serialize = \case Redirect host port -> serializeLabeledEntryMulti "NRedirect" host $ sLast port diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index ad6719e..20f461d 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -24,7 +24,7 @@ import qualified Networking.NetworkConnection as Ncon -- import qualified Networking.Common as NC -- | the interpretation monad -type InterpretM a = T.ReaderT (PEnv, MVar.MVar (Map.Map Int ServerSocket)) IO a +type InterpretM a = T.ReaderT (PEnv, (MVar.MVar (Map.Map Int ServerSocket), MVar.MVar ActiveConnections)) IO a extendEnv :: String -> Value -> PEnv -> PEnv extendEnv = curry (:) @@ -45,6 +45,11 @@ data FuncType = FuncType PEnv String S.Type S.Type instance Show FuncType where show (FuncType _ s t1 t2) = "FuncType " ++ show s ++ " " ++ show t1 ++ " " ++ show t2 +data NetworkAddress = NetworkAddress {hostname :: String, port :: String} + deriving (Eq, Show) + +type ActiveConnections = Map.Map NetworkAddress Handle + type ServerSocket = (MVar.MVar (Map.Map String (NCon.NetworkConnection Value)), MVar.MVar [(String, Type)], String) type ValueRepr = String diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 60ed44d..b167f61 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -24,6 +24,7 @@ import Networking.Messages %name parseValues Values %name parseMessages Messages %name parseResponses Responses +%name parseConversation ConversationSession -- %name parseSStringTypeElement SStringTypeElement -- %name parseSStringTypeElements SStringTypeElements -- %name parseSStringTypeArray SStringTypeArray @@ -130,6 +131,8 @@ import Networking.Messages nokayintroduce { T _ T.NOkayIntroduce } nokaysync { T _ T.NOkaySync } nwait { T _ T.NWait} + nconversationmessage { T _ T.NConversationMessage} + nconversationresponse { T _ T.NConversationResponse} gunit { T _ T.GUnit } glabel { T _ T.GLabel } @@ -298,6 +301,9 @@ Responses : nredirect '(' String ')' '(' String ')' {Redirect $3 $6} | nokaysync '(' SValuesArray ')' {OkaySync $3} | nwait {Wait} +ConversationSession : nconversationmessage '(' String ')' '(' Messages ')' {ConversationMessage $3 $6} + | nconversationresponse '(' String ')' '(' Responses ')' {ConversationResponse $3 $6} + PEnvEntry : penventry '(' String ')' '(' Values ')' {($3, $6)} diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index 1babb03..162222c 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -143,6 +143,8 @@ tokens :- "NOkayIntroduce" { tok $ const NOkayIntroduce } "NOkaySync" { tok $ const NOkaySync } "NWait" { tok $ const NWait} + "NConversationMessage" { tok $ const NConversationMessage } + "NConversationResponse" { tok $ const NConversationResponse } Double\:[\-]?[0-9]+[\.][0-9]+ { tok $ Double . read . (drop 7) } Int\:[\-]?[0-9]+ { tok $ Int . read . (drop 4)} @@ -272,6 +274,8 @@ data Token | NOkayIntroduce | NOkaySync | NWait + | NConversationMessage + | NConversationResponse | String String | Int Int diff --git a/test/Utils.hs b/test/Utils.hs index aa6f869..2f8bbe6 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -7,6 +7,7 @@ import ProcessEnvironment import Control.Monad.Reader (runReaderT) import Test.Hspec import Control.Concurrent.MVar +import qualified Data.Map as Map shouldParseDecl :: HasCallStack => String -> Decl -> Expectation shouldParseDecl source expected = @@ -19,8 +20,11 @@ raiseFailure msg = do shouldInterpretTo :: [Decl] -> Value -> Expectation shouldInterpretTo givenDecls expectedValue = do - mvar <- newEmptyMVar - value <- runReaderT (interpretDecl givenDecls) ([], mvar) + sockets <- newEmptyMVar + handles <- newEmptyMVar + putMVar sockets Map.empty + putMVar handles Map.empty + value <- runReaderT (interpretDecl givenDecls) ([], (sockets, handles)) value `shouldBe` expectedValue shouldThrowCastException :: [Decl] -> Expectation @@ -29,16 +33,25 @@ shouldThrowCastException givenDecls = isCastException (CastException _) = True isCastException _ = False in do - mvar <- newEmptyMVar - runReaderT (interpretDecl givenDecls) ([], mvar) `shouldThrow` isCastException + sockets <- newEmptyMVar + handles <- newEmptyMVar + putMVar sockets Map.empty + putMVar handles Map.empty + runReaderT (interpretDecl givenDecls) ([], (sockets, handles)) `shouldThrow` isCastException shouldThrowInterpreterException :: Decl -> InterpreterException -> Expectation shouldThrowInterpreterException given except = do - mvar <- newEmptyMVar - runReaderT (interpretDecl [given]) ([], mvar) `shouldThrow` (== except) + sockets <- newEmptyMVar + handles <- newEmptyMVar + putMVar sockets Map.empty + putMVar handles Map.empty + runReaderT (interpretDecl [given]) ([], (sockets, handles)) `shouldThrow` (== except) shouldInterpretTypeTo :: Type -> NFType -> Expectation shouldInterpretTypeTo t expected = do - mvar <- newEmptyMVar - nft <- runReaderT (evalType t) ([], mvar) + sockets <- newEmptyMVar + handles <- newEmptyMVar + putMVar sockets Map.empty + putMVar handles Map.empty + nft <- runReaderT (evalType t) ([], (sockets, handles)) nft `shouldBe` expected diff --git a/testNWCount.sh b/testNWCount.sh index e29e4a4..db51a88 100644 --- a/testNWCount.sh +++ b/testNWCount.sh @@ -1,4 +1,4 @@ -for i in {1..100}; do +for i in {1..1000}; do clear; echo "$i Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/add/server.ldgvnw & stack run ldgv -- interpret < dev-examples/add/client.ldgvnw & wait); clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/simple/server.ldgvnw & stack run ldgv -- interpret < dev-examples/simple/client.ldgvnw & wait); clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirectional/client.ldgvnw & wait); From eb07bc9741b75407483b481cc4a4ae8b76aa4c29 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Fri, 27 Jan 2023 15:23:02 +0100 Subject: [PATCH 086/229] Added new tests and code for future fast networking --- dev-examples/handoff3/client.ldgvnw | 30 ++++++ dev-examples/handoff3/handoff.ldgvnw | 28 ++++++ dev-examples/handoff3/server.ldgvnw | 20 ++++ dev-examples/handoff4/client.ldgvnw | 22 +++++ dev-examples/handoff4/handoff.ldgvnw | 20 ++++ dev-examples/handoff4/server.ldgvnw | 29 ++++++ ldgv.cabal | 4 +- src/Config.hs | 4 +- src/Networking/NetworkingMethod/Fast.hs | 87 ++++++++++++++++++ src/Networking/NetworkingMethod/Stateless.hs | 97 ++++++++++++++++++++ src/ValueParsing/ValueGrammar.y | 2 +- 11 files changed, 339 insertions(+), 4 deletions(-) create mode 100644 dev-examples/handoff3/client.ldgvnw create mode 100644 dev-examples/handoff3/handoff.ldgvnw create mode 100644 dev-examples/handoff3/server.ldgvnw create mode 100644 dev-examples/handoff4/client.ldgvnw create mode 100644 dev-examples/handoff4/handoff.ldgvnw create mode 100644 dev-examples/handoff4/server.ldgvnw create mode 100644 src/Networking/NetworkingMethod/Fast.hs create mode 100644 src/Networking/NetworkingMethod/Stateless.hs diff --git a/dev-examples/handoff3/client.ldgvnw b/dev-examples/handoff3/client.ldgvnw new file mode 100644 index 0000000..874ca29 --- /dev/null +++ b/dev-examples/handoff3/client.ldgvnw @@ -0,0 +1,30 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit +type SendOneInt : ! ~ssn = !Int. Unit +type SendSendOneInt : ! ~ssn = !SendOneInt. ?SendOneInt. Unit + +val send1 (c: SendInt) : SendOneInt = + let x = ((send c) 1) in + (x) + +val send2 (c2: SendOneInt) = + let y = ((send c2) 42) in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val main : Unit +val main = + -- let sock = (create 4141) in + let con = (connect 4141 SendInt "127.0.0.1" 4242) in -- This cannot be localhost, since this might break on containerized images + let oneint = (send1 con) in + let con2 = (connect 4141 SendSendOneInt "127.0.0.1" 4343) in + let con3 = (send con2) oneint in + let = recv con3 in + send2 oneint + diff --git a/dev-examples/handoff3/handoff.ldgvnw b/dev-examples/handoff3/handoff.ldgvnw new file mode 100644 index 0000000..70b7113 --- /dev/null +++ b/dev-examples/handoff3/handoff.ldgvnw @@ -0,0 +1,28 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit +type SendOneInt : ! ~ssn = !Int. Unit +type SendSendOneInt : ! ~ssn = !SendOneInt. ?SendOneInt. Unit + +val send1 (c: SendInt) : SendOneInt = + let x = ((send c) 1) in + (x) + +val send2 (c2: SendOneInt) = + let y = ((send c2) 42) in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val main : Unit +val main = + -- let con = (create 4343) in + let con = (accept 4343 (dualof SendSendOneInt)) in + let = recv con in + let c2 = (send c2) oneint in + () + diff --git a/dev-examples/handoff3/server.ldgvnw b/dev-examples/handoff3/server.ldgvnw new file mode 100644 index 0000000..0a9aa08 --- /dev/null +++ b/dev-examples/handoff3/server.ldgvnw @@ -0,0 +1,20 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let y = ((send x) 42) in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val main : Int +val main = + -- let con = (create 4242) in + let con = (accept 4242 (dualof SendInt)) in + add2 con diff --git a/dev-examples/handoff4/client.ldgvnw b/dev-examples/handoff4/client.ldgvnw new file mode 100644 index 0000000..45c3aa7 --- /dev/null +++ b/dev-examples/handoff4/client.ldgvnw @@ -0,0 +1,22 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let y = ((send x) 42) in + -- let z = end y in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + -- let c4 = end c3 in + (m + n) + +val main : Unit +val main = + let sock = 4444 in + let con = (connect sock SendInt "127.0.0.1" 4242 ) in -- This cannot be localhost, since this might break on containerized images + send2 con diff --git a/dev-examples/handoff4/handoff.ldgvnw b/dev-examples/handoff4/handoff.ldgvnw new file mode 100644 index 0000000..53b4303 --- /dev/null +++ b/dev-examples/handoff4/handoff.ldgvnw @@ -0,0 +1,20 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit +type SendOneInt : ! ~ssn = ?Int. Unit +type SendSendOneInt : ! ~ssn = !SendOneInt. ?SendOneInt. Unit +-- type SendOneIntInv : ! ~ssn = ?Int. Unit + +val main : Unit +val main = + let sock = 4343 in + let con = (connect sock (dualof SendSendOneInt) "127.0.0.1" 4242) in + let = recv con in + let c3 = (send c2) oneint in + -- let = recv oneint in + + -- let c4 = end c2 in + -- let c5 = end c3 in + () + diff --git a/dev-examples/handoff4/server.ldgvnw b/dev-examples/handoff4/server.ldgvnw new file mode 100644 index 0000000..feb3ecb --- /dev/null +++ b/dev-examples/handoff4/server.ldgvnw @@ -0,0 +1,29 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit +type SendOneInt : ! ~ssn = ?Int. Unit +type SendSendOneInt : ! ~ssn = !SendOneInt. ?SendOneInt. Unit +-- type SendOneIntInv : ! ~ssn = ?Int. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let y = ((send x) 42) in + -- let z = end y in + () + +val add2 (c1: dualof SendInt) (c3: SendSendOneInt)= + let = recv c1 in + let y = ((send c3) c2) in + let = recv y in + let = recv oneint in + -- let z = end y in + (m+n) + +-- Hier problematisch ldgv hat noch kein Konzept wie beim akzeptieren zwischen verschiedenen Types ungerschieden werden kann +val main : Int +val main = + let sock = 4242 in + let con1 = (accept sock (dualof SendInt)) in + let con2 = (accept sock (SendSendOneInt)) in + add2 con1 con2 diff --git a/ldgv.cabal b/ldgv.cabal index 117f3f7..010ec45 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.35.0. +-- This file has been generated from package.yaml by hpack version 0.34.6. -- -- see: https://github.com/sol/hpack @@ -70,6 +70,8 @@ library Networking.DirectionalConnection Networking.Messages Networking.NetworkConnection + Networking.NetworkingMethod.Fast + Networking.NetworkingMethod.Stateless Networking.Serialize Networking.Server Networking.UserID diff --git a/src/Config.hs b/src/Config.hs index df72d9c..d714365 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -16,13 +16,13 @@ debugLevel :: DebugLevel debugLevel = DebugNetwork --debugLevel = DebugNone - +{- data NetworkingMethod = NetworkingStateless | NetworkingFast deriving (Eq, Ord, Show) networkingMethod :: NetworkingMethod networkingMethod = NetworkingStateless - +-} trace :: String -> a -> a trace s a | debugLevel > DebugNetwork = D.trace s a diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs new file mode 100644 index 0000000..3103795 --- /dev/null +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -0,0 +1,87 @@ +module Networking.NetworkingMethod.Fast where + +import Network.Socket +import GHC.IO.Handle +import System.IO +import qualified Control.Concurrent.MVar as MVar +import qualified Control.Concurrent.Chan as Chan +import qualified Data.Maybe +import qualified Data.Map as Map +import Control.Concurrent +import Control.Monad + +import Networking.Messages +import Networking.UserID +import qualified Networking.Serialize as NSerialize +import qualified ValueParsing.ValueTokens as VT +import qualified ValueParsing.ValueGrammar as VG +import qualified Config +import qualified Networking.NetworkingMethod.Stateless as Stateless +type Conversation = (String, Handle, MVar.MVar (Map.Map String (String, Responses))) + +type NetworkAddress = (String, String) +-- deriving (Eq, Show, Ord) + +type ActiveConnections = Map.Map NetworkAddress Connection + +type Connection = (Handle, Chan.Chan (String, (String, Messages)), MVar.MVar (Map.Map String (String, Responses))) + + +sendMessage :: Messages -> Conversation -> IO () +sendMessage value conversation@(cid, handle, responses) = Stateless.sendMessage (ConversationMessage cid value) handle + +sendResponse :: Responses -> Conversation -> IO () +sendResponse value conversation@(cid, handle, responses) = Stateless.sendResponse (ConversationResponse cid value) handle + +conversationHandler :: Handle -> IO Connection +conversationHandler handle = do + chan <- Chan.newChan + mvar <- MVar.newEmptyMVar + forkIO $ forever $ Stateless.recieveMessage handle VG.parseConversation (\_ -> return ()) (\mes des -> case des of + ConversationMessage cid message -> Chan.writeChan chan (cid, (mes, message)) + ConversationResponse cid response -> do + mymap <- MVar.takeMVar mvar + MVar.putMVar mvar $ Map.insert cid (mes, response) mymap + ) + return (handle, chan, mvar) + + +recieveResponse :: Conversation -> Int -> Int -> IO (Maybe Responses) +recieveResponse conversation@(cid, handle, mvar) waitTime tries = do + responsesMap <- MVar.takeMVar mvar + case Map.lookup cid responsesMap of + Just (messages, deserial) -> do + MVar.putMVar mvar $ Map.delete cid responsesMap + return $ Just deserial + Nothing -> do + MVar.putMVar mvar responsesMap + if tries /= 0 then recieveResponse conversation waitTime $ max (tries-1) (-1) else return Nothing + +recieveNewMessage :: Connection -> IO (Conversation, String, Messages) +recieveNewMessage connection@(handle, chan, mvar) = do + (cid, (serial, deserial)) <- Chan.readChan chan + return ((cid, handle, mvar), serial, deserial) + + +startConversation :: MVar.MVar ActiveConnections -> String -> String -> Int -> Int -> IO (Maybe Conversation) +startConversation acmvar hostname port waitTime tries = do + conversationid <- newRandomUserID + connectionMap <- MVar.takeMVar acmvar + case Map.lookup (hostname, port) connectionMap of + Just (handle, chan, mvar) -> do + MVar.putMVar acmvar connectionMap + return $ Just (conversationid, handle, mvar) + Nothing -> do + mbyNewHandle <- Stateless.startConversation hostname port waitTime tries + case mbyNewHandle of + Just handle -> do + newconnection@(handle, chan, mvar) <- conversationHandler handle + MVar.putMVar acmvar $ Map.insert (hostname, port) newconnection connectionMap + return $ Just (conversationid, handle, mvar) + Nothing -> do + MVar.putMVar acmvar connectionMap + return Nothing + +endConversation :: Conversation -> Int -> Int -> IO () +endConversation _ _ _ = return () + diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs new file mode 100644 index 0000000..bdf018c --- /dev/null +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -0,0 +1,97 @@ +module Networking.NetworkingMethod.Stateless where + +import Network.Socket +import GHC.IO.Handle +import System.IO +import qualified Control.Concurrent.MVar as MVar +import qualified Data.Maybe +import Control.Concurrent + +import Networking.Messages +import qualified Networking.Serialize as NSerialize +import qualified ValueParsing.ValueTokens as VT +import qualified ValueParsing.ValueGrammar as VG +import qualified Config + + + +sendMessage :: NSerialize.Serializable a => a -> Handle -> IO () +sendMessage value handle = do + serializedValue <- NSerialize.serialize value + hPutStrLn handle (serializedValue ++" ") + +sendResponse :: NSerialize.Serializable a => a -> Handle -> IO () +sendResponse = sendMessage + +recieveMessage :: Handle -> VT.Alex t -> (String -> IO b) -> (String -> t -> IO b) -> IO b +recieveMessage handle grammar fallbackResponse messageHandler = do + message <- hGetLine handle + case VT.runAlex message grammar of + Left err -> do + Config.traceNetIO $ "Error during recieving a networkmessage: "++err + fallbackResponse message + Right deserialmessage -> do + -- Config.traceNetIO $ "New superficially valid message recieved: "++message + messageHandler message deserialmessage + +startConversation :: String -> String -> Int -> Int -> IO (Maybe Handle) +startConversation hostname port waitTime tries = do + let hints = defaultHints { + addrFamily = AF_INET + , addrFlags = [] + , addrSocketType = Stream + } + handleMVar <- MVar.newEmptyMVar + threadid <- forkIO (do + Config.traceNetIO $ "Trying to connect to: " ++ hostname ++":"++port + addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port + clientsocket <- openSocketNC $ head addrInfo + connect clientsocket $ addrAddress $ head addrInfo + handle <- getSocketFromHandle clientsocket + MVar.putMVar handleMVar handle + ) + getFromNetworkThread threadid handleMVar waitTime tries + + +getFromNetworkThread :: ThreadId -> MVar.MVar a -> Int -> Int -> IO (Maybe a) +getFromNetworkThread = getFromNetworkThreadWithModification Just + +getFromNetworkThreadWithModification :: (a -> Maybe b) -> ThreadId -> MVar a -> Int -> Int -> IO (Maybe b) +getFromNetworkThreadWithModification func threadid mvar waitTime currentTry = do + mbyResult <- MVar.tryReadMVar mvar + case mbyResult of + Just handle -> return $ func handle + Nothing -> if currentTry /= 0 then do + threadDelay waitTime + getFromNetworkThreadWithModification func threadid mvar waitTime $ max (currentTry-1) (-1) + else do + killThread threadid + return Nothing + +recieveResponse :: Handle -> Int -> Int -> IO (Maybe Responses) +recieveResponse handle waitTime tries = do + retVal <- MVar.newEmptyMVar + threadid <- forkIO $ recieveMessage handle VG.parseResponses (\_ -> MVar.putMVar retVal Nothing) (\_ des -> MVar.putMVar retVal $ Just des) + getFromNetworkThreadWithModification id threadid retVal waitTime tries + +recieveNewMessage :: Handle -> IO (Handle, String, Messages) +recieveNewMessage handle = do + recieveMessage handle VG.parseMessages (\_ -> recieveNewMessage handle) $ \s des -> return (handle, s, des) + + +endConversation :: Handle -> Int -> Int -> IO () +endConversation handle waitTime tries = do + finished <- MVar.newEmptyMVar + threadid <- forkIO $ hClose handle >> MVar.putMVar finished True + _ <- getFromNetworkThread threadid finished waitTime tries + return () + + +openSocketNC :: AddrInfo -> IO Socket +openSocketNC addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + +getSocketFromHandle :: Socket -> IO Handle +getSocketFromHandle socket = do + hdl <- socketToHandle socket ReadWriteMode + hSetBuffering hdl NoBuffering + return hdl \ No newline at end of file diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index b167f61..483059f 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -1,5 +1,5 @@ { -module ValueParsing.ValueGrammar (parseValues, parseMessages, parseResponses) where +module ValueParsing.ValueGrammar (parseValues, parseMessages, parseResponses, parseConversation) where import Control.Monad import qualified Data.List as List From 11416fd7e31cd9b492ce0709ee401f7cd3072a7b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Fri, 27 Jan 2023 17:51:13 +0100 Subject: [PATCH 087/229] Work towards fast networking --- exe/Main.hs | 1 + ldgv.cabal | 2 + src/Interpreter.hs | 36 +-- src/Networking/Client.hs | 2 +- src/Networking/Messages.hs | 6 +- src/Networking/NetworkingMethod/Fast.hs | 57 ++++- .../NetworkingMethodCommon.hs | 17 ++ src/Networking/NetworkingMethod/Stateless.hs | 51 ++++- src/Networking/Serialize.hs | 2 +- src/Networking/Server.hs | 3 +- src/PrettySyntax.hs | 1 + src/ProcessEnvironment.hs | 208 +----------------- src/ProcessEnvironmentTypes.hs | 200 +++++++++++++++++ src/ValueParsing/ValueGrammar.y | 2 +- test/CSpec.hs | 3 +- test/InterpreterSpec.hs | 1 + test/Utils.hs | 15 +- 17 files changed, 364 insertions(+), 243 deletions(-) create mode 100644 src/Networking/NetworkingMethod/NetworkingMethodCommon.hs create mode 100644 src/ProcessEnvironmentTypes.hs diff --git a/exe/Main.hs b/exe/Main.hs index f1ae463..def4002 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -27,6 +27,7 @@ import qualified C.Compile as C import qualified C.Generate as C import qualified Interpreter as I import qualified ProcessEnvironment as P +import qualified ProcessEnvironmentTypes as P import qualified Syntax import qualified Typechecker as T diff --git a/ldgv.cabal b/ldgv.cabal index 010ec45..c8f5884 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -71,6 +71,7 @@ library Networking.Messages Networking.NetworkConnection Networking.NetworkingMethod.Fast + Networking.NetworkingMethod.NetworkingMethodCommon Networking.NetworkingMethod.Stateless Networking.Serialize Networking.Server @@ -79,6 +80,7 @@ library Parsing.Grammar Parsing.Tokens ProcessEnvironment + ProcessEnvironmentTypes Syntax Typechecker ValueParsing.ValueGrammar diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 5d27fc7..3610bba 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -20,6 +20,7 @@ import Data.Foldable (find) import Data.Maybe (fromJust, fromMaybe) import qualified Data.Map as Map import ProcessEnvironment +import Networking.NetworkingMethod.NetworkingMethodCommon import qualified Control.Monad as M import Control.Monad.Reader as R import Control.Applicative ((<|>)) @@ -45,7 +46,8 @@ import qualified Networking.NetworkConnection as NCon -- import ProcessEnvironment (CommunicationChannel(CommunicationChannel, ccChannelState, ccPartnerUserID), ConnectionInfo (ciReadChannel, ciWriteChannel)) -- import ProcessEnvironment import qualified Control.Concurrent as MVar -import ProcessEnvironment (disableOldVChan) +import ProcessEnvironment +import ProcessEnvironmentTypes import Networking.NetworkConnection (NetworkConnection(ncPartnerUserID)) import qualified Control.Concurrent as MVar import qualified Control.Concurrent as MVar @@ -56,6 +58,9 @@ import qualified Control.Concurrent as MVar -- import qualified Networking.NetworkConnection as NCon -- import qualified Networking.NetworkConnection as NCon +import qualified Networking.NetworkingMethod.Stateless as NetMethod +-- import qualified Networking.NetworkingMethod.Fast as NetMethod + data InterpreterException = MathException String | LookupException String @@ -95,10 +100,9 @@ blame exp = throw $ CastException exp interpret :: [Decl] -> IO Value interpret decls = do sockets <- MVar.newEmptyMVar - handles <- MVar.newEmptyMVar + activeConnections <- NetMethod.createActiveConnections MVar.putMVar sockets Map.empty - MVar.putMVar handles Map.empty - R.runReaderT (interpretDecl decls) ([], (sockets, handles)) + R.runReaderT (interpretDecl decls) ([], (sockets, activeConnections)) interpretDecl :: [Decl] -> InterpretM Value interpretDecl (DFun "main" _ e _:_) = interpret' e @@ -153,8 +157,8 @@ eval = \case case v of VPair {} -> do C.traceIO $ "Interpreting pair cast expression: Value(" ++ show v ++ ") NFType(" ++ show nft1 ++ ") NFType(" ++ show nft2 ++ ")" - (env, (sockets, handles)) <- ask - v' <- lift $ reducePairCast sockets handles v (toNFPair nft1) (toNFPair nft2) + (env, (sockets, activeConnections)) <- ask + v' <- lift $ reducePairCast sockets activeConnections v (toNFPair nft1) (toNFPair nft2) maybe (blame cast) return v' _ -> let v' = reduceCast v nft1 nft2 in maybe (blame cast) return v' Var s -> ask >>= \(env, _) -> maybe (throw $ LookupException s) (liftIO . pure) (lookup s env) @@ -233,7 +237,7 @@ eval = \case val <- interpret' e case val of VInt port -> do - (env, (sockets, handles)) <- ask + (env, (sockets, activeConnections)) <- ask (mvar, clientlist, ownport) <- liftIO $ NS.ensureSocket port sockets -- newuser <- liftIO $ Chan.readChan chan liftIO $ C.traceIO "Searching for correct communicationpartner" @@ -257,7 +261,7 @@ eval = \case val <- interpret' e0 case val of VInt port -> do - (env, (sockets, handles)) <- ask + (env, (sockets, activeConnections)) <- ask (networkconmapmvar, chan, ownport) <- liftIO $ NS.ensureSocket port sockets addressVal <- interpret' e1 case addressVal of @@ -414,19 +418,19 @@ toNFPair :: NFType -> NFType toNFPair (NFGType (GPair)) = NFPair (FuncType [] "x" TDyn TDyn) toNFPair t = t -reducePairCast :: MVar.MVar (Map.Map Int ServerSocket) -> MVar.MVar ActiveConnections -> Value -> NFType -> NFType -> IO (Maybe Value) -reducePairCast sockets handles (VPair v w) (NFPair (FuncType penv s t1 t2)) (NFPair (FuncType penv' s' t1' t2')) = do - mv' <- reduceComponent sockets handles v (penv, t1) (penv', t1') +reducePairCast :: MVar.MVar (Map.Map Int ServerSocket) -> ActiveConnections -> Value -> NFType -> NFType -> IO (Maybe Value) +reducePairCast sockets activeConnections (VPair v w) (NFPair (FuncType penv s t1 t2)) (NFPair (FuncType penv' s' t1' t2')) = do + mv' <- reduceComponent sockets activeConnections v (penv, t1) (penv', t1') case mv' of Nothing -> return Nothing Just v' -> do - mw' <- reduceComponent sockets handles w ((s, v) : penv, t2) ((s', v') : penv', t2') + mw' <- reduceComponent sockets activeConnections w ((s, v) : penv, t2) ((s', v') : penv', t2') return $ liftM2 VPair mv' mw' where - reduceComponent :: MVar.MVar (Map.Map Int ServerSocket) -> MVar.MVar ActiveConnections -> Value -> (PEnv, Type) -> (PEnv, Type) -> IO (Maybe Value) - reduceComponent sockets handles v (penv, t) (penv', t') = do - nft <- R.runReaderT (evalType t) (penv, (sockets, handles)) - nft' <- R.runReaderT (evalType t') (penv', (sockets, handles)) + reduceComponent :: MVar.MVar (Map.Map Int ServerSocket) -> ActiveConnections -> Value -> (PEnv, Type) -> (PEnv, Type) -> IO (Maybe Value) + reduceComponent sockets activeConnections v (penv, t) (penv', t') = do + nft <- R.runReaderT (evalType t) (penv, (sockets, activeConnections)) + nft' <- R.runReaderT (evalType t') (penv', (sockets, activeConnections)) return $ reduceCast v nft nft' reducePairCast _ _ _ _ _ = return Nothing diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index f1eb0e7..f6052ea 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -4,7 +4,7 @@ module Networking.Client where import qualified Config import Networking.NetworkConnection as NCon -import ProcessEnvironment +import ProcessEnvironmentTypes import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG import Networking.Messages diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs index 43f9047..22d51b9 100644 --- a/src/Networking/Messages.hs +++ b/src/Networking/Messages.hs @@ -2,8 +2,12 @@ module Networking.Messages where -import ProcessEnvironment +import ProcessEnvironmentTypes import Syntax +import GHC.IO.Handle +import qualified Control.Concurrent.Chan as Chan +import qualified Control.Concurrent.MVar as MVar +import qualified Data.Map as Map type UserID = String type Hostname = String diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index 3103795..84b4b62 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -1,5 +1,6 @@ module Networking.NetworkingMethod.Fast where +import Networking.NetworkingMethod.NetworkingMethodCommon import Network.Socket import GHC.IO.Handle import System.IO @@ -11,20 +12,22 @@ import Control.Concurrent import Control.Monad import Networking.Messages +import Networking.NetworkConnection import Networking.UserID +import qualified Syntax import qualified Networking.Serialize as NSerialize import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG import qualified Config import qualified Networking.NetworkingMethod.Stateless as Stateless +import ProcessEnvironmentTypes + type Conversation = (String, Handle, MVar.MVar (Map.Map String (String, Responses))) -type NetworkAddress = (String, String) +-- type NetworkAddress = (String, String) -- deriving (Eq, Show, Ord) -type ActiveConnections = Map.Map NetworkAddress Connection - -type Connection = (Handle, Chan.Chan (String, (String, Messages)), MVar.MVar (Map.Map String (String, Responses))) +-- type Connectionhandler = MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Messages -> IO () sendMessage :: Messages -> Conversation -> IO () @@ -63,7 +66,7 @@ recieveNewMessage connection@(handle, chan, mvar) = do return ((cid, handle, mvar), serial, deserial) -startConversation :: MVar.MVar ActiveConnections -> String -> String -> Int -> Int -> IO (Maybe Conversation) +startConversation :: ActiveConnectionsFast -> String -> String -> Int -> Int -> IO (Maybe Conversation) startConversation acmvar hostname port waitTime tries = do conversationid <- newRandomUserID connectionMap <- MVar.takeMVar acmvar @@ -72,7 +75,7 @@ startConversation acmvar hostname port waitTime tries = do MVar.putMVar acmvar connectionMap return $ Just (conversationid, handle, mvar) Nothing -> do - mbyNewHandle <- Stateless.startConversation hostname port waitTime tries + mbyNewHandle <- Stateless.startConversation Nothing hostname port waitTime tries case mbyNewHandle of Just handle -> do newconnection@(handle, chan, mvar) <- conversationHandler handle @@ -82,6 +85,48 @@ startConversation acmvar hostname port waitTime tries = do MVar.putMVar acmvar connectionMap return Nothing +createActiveConnections :: IO ActiveConnectionsFast +createActiveConnections = do + activeConnections <- MVar.newEmptyMVar + MVar.putMVar activeConnections Map.empty + return activeConnections + +{- +acceptConversations :: ActiveConnectionsFast -> ConnectionHandler -> Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), MVar.MVar [(String, Syntax.Type)]) +acceptConversations ActiveConnectionsFast connectionhandler port = do + sock <- socket AF_INET Stream 0 + setSocketOption sock ReuseAddr 1 + let hints = defaultHints { + addrFamily = AF_INET + , addrFlags = [AI_PASSIVE] + , addrSocketType = Stream + } + addrInfo <- getAddrInfo (Just hints) Nothing $ Just $ show port + bind sock $ addrAddress $ head addrInfo + listen sock 1024 + mvar <- MVar.newEmptyMVar + MVar.putMVar mvar Map.empty + clientlist <- MVar.newEmptyMVar + MVar.putMVar clientlist [] + forkIO $ acceptClients connectionhandler mvar clientlist sock $ show port + return (mvar, clientlist) + where + acceptClients :: ActiveConnectionsFast -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> Socket -> String -> IO () + acceptClients ActiveConnectionsFast connectionhandler mvar clientlist socket ownport = do + Config.traceIO "Waiting for clients" + clientsocket <- accept socket + Config.traceIO "Accepted new client" + + forkIO $ acceptClient activeConections connectionhandler mvar clientlist clientsocket ownport + acceptClients ActiveConnectionsFast connectionhandler mvar clientlist socket ownport + + acceptClient :: ActiveConnectionsFast -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> String -> IO () + acceptClient ActiveConnectionsFast connectionhandler mvar clientlist clientsocket ownport = do + hdl <- NC.getHandle $ fst clientsocket + NC.recieveMessage hdl VG.parseMessages (\_ -> return ()) $ connectionhandler mvar clientlist clientsocket hdl ownport + hClose hdl +-} + endConversation :: Conversation -> Int -> Int -> IO () endConversation _ _ _ = return () diff --git a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs new file mode 100644 index 0000000..55eec49 --- /dev/null +++ b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs @@ -0,0 +1,17 @@ +module Networking.NetworkingMethod.NetworkingMethodCommon where + +import GHC.IO.Handle +import qualified Control.Concurrent.Chan as Chan +import qualified Control.Concurrent.MVar as MVar +import qualified Data.Map as Map +import Networking.Messages + +type ActiveConnections = ActiveConnectionsStateless + +data ActiveConnectionsStateless = ActiveConnectionsStateless + +type Connection = (Handle, Chan.Chan (String, (String, Messages)), MVar.MVar (Map.Map String (String, Responses))) + +type ActiveConnectionsFast = MVar.MVar (Map.Map NetworkAddress Connection) + +type NetworkAddress = (String, String) \ No newline at end of file diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index bdf018c..2735371 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -1,18 +1,25 @@ module Networking.NetworkingMethod.Stateless where +import Networking.NetworkingMethod.NetworkingMethodCommon + import Network.Socket import GHC.IO.Handle import System.IO import qualified Control.Concurrent.MVar as MVar +import qualified Data.Map as Map import qualified Data.Maybe import Control.Concurrent import Networking.Messages +import Networking.NetworkConnection +import ProcessEnvironmentTypes import qualified Networking.Serialize as NSerialize import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG import qualified Config +import qualified Syntax +type ConnectionHandler = MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Messages -> IO () sendMessage :: NSerialize.Serializable a => a -> Handle -> IO () @@ -34,8 +41,8 @@ recieveMessage handle grammar fallbackResponse messageHandler = do -- Config.traceNetIO $ "New superficially valid message recieved: "++message messageHandler message deserialmessage -startConversation :: String -> String -> Int -> Int -> IO (Maybe Handle) -startConversation hostname port waitTime tries = do +startConversation :: a -> String -> String -> Int -> Int -> IO (Maybe Handle) +startConversation _ hostname port waitTime tries = do let hints = defaultHints { addrFamily = AF_INET , addrFlags = [] @@ -52,6 +59,42 @@ startConversation hostname port waitTime tries = do ) getFromNetworkThread threadid handleMVar waitTime tries +acceptConversations :: a -> ConnectionHandler -> Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), MVar.MVar [(String, Syntax.Type)]) +acceptConversations _ connectionhandler port = do + -- serverid <- UserID.newRandomUserID + sock <- socket AF_INET Stream 0 + setSocketOption sock ReuseAddr 1 + let hints = defaultHints { + addrFamily = AF_INET + , addrFlags = [AI_PASSIVE] + , addrSocketType = Stream + } + addrInfo <- getAddrInfo (Just hints) Nothing $ Just $ show port + bind sock $ addrAddress $ head addrInfo + listen sock 1024 + mvar <- MVar.newEmptyMVar + MVar.putMVar mvar Map.empty + clientlist <- MVar.newEmptyMVar + MVar.putMVar clientlist [] + forkIO $ acceptClients connectionhandler mvar clientlist sock $ show port + return (mvar, clientlist) + where + acceptClients :: ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> Socket -> String -> IO () + acceptClients connectionhandler mvar clientlist socket ownport = do + Config.traceIO "Waiting for clients" + clientsocket <- accept socket + Config.traceIO "Accepted new client" + + forkIO $ acceptClient connectionhandler mvar clientlist clientsocket ownport + acceptClients connectionhandler mvar clientlist socket ownport + + acceptClient :: ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> String -> IO () + acceptClient connectionhandler mvar clientlist clientsocket ownport = do + hdl <- getSocketFromHandle $ fst clientsocket + recieveMessage hdl VG.parseMessages (\_ -> return ()) $ connectionhandler mvar clientlist clientsocket hdl ownport + hClose hdl + + getFromNetworkThread :: ThreadId -> MVar.MVar a -> Int -> Int -> IO (Maybe a) getFromNetworkThread = getFromNetworkThreadWithModification Just @@ -85,7 +128,9 @@ endConversation handle waitTime tries = do threadid <- forkIO $ hClose handle >> MVar.putMVar finished True _ <- getFromNetworkThread threadid finished waitTime tries return () - + +createActiveConnections :: IO ActiveConnectionsStateless +createActiveConnections = return ActiveConnectionsStateless openSocketNC :: AddrInfo -> IO Socket openSocketNC addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index b7562c2..4920618 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -9,7 +9,7 @@ import Syntax import Kinds import Data.Set import Control.Exception -import ProcessEnvironment +import ProcessEnvironmentTypes import Networking.Messages import qualified Networking.DirectionalConnection as DC import qualified Networking.NetworkConnection as NCon diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 91fd19d..6113c76 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -15,7 +15,7 @@ import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG import qualified Networking.Common as NC import qualified Networking.Serialize as NSerialize -import ProcessEnvironment +import ProcessEnvironmentTypes import qualified Syntax import Control.Exception @@ -29,7 +29,6 @@ import qualified Networking.Common as NC import qualified Config import qualified Networking.NetworkConnection as NCon import qualified Control.Concurrent as MVar -import ProcessEnvironment (ServerSocket) import qualified Networking.Client as NC import Control.Monad diff --git a/src/PrettySyntax.hs b/src/PrettySyntax.hs index 12ff594..e3f1012 100644 --- a/src/PrettySyntax.hs +++ b/src/PrettySyntax.hs @@ -7,6 +7,7 @@ module PrettySyntax (Pretty(), pretty, pshow) where import Kinds import Syntax import ProcessEnvironment +import ProcessEnvironmentTypes import Data.Text.Prettyprint.Doc import qualified Data.Set as Set diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index 20f461d..11c1123 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} module ProcessEnvironment where +import ProcessEnvironmentTypes import Syntax as S import GHC.IO.Handle import Control.Concurrent.Chan as C @@ -21,209 +22,10 @@ import Network.Socket import qualified Networking.NetworkConnection as NCon import qualified Networking.NetworkConnection as NCOn import qualified Networking.NetworkConnection as Ncon + +import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC -- import qualified Networking.Common as NC -- | the interpretation monad -type InterpretM a = T.ReaderT (PEnv, (MVar.MVar (Map.Map Int ServerSocket), MVar.MVar ActiveConnections)) IO a - -extendEnv :: String -> Value -> PEnv -> PEnv -extendEnv = curry (:) - --- | a Process Envronment maps identifiers to Values of expressions and stores -type PEnv = [PEnvEntry] -type PEnvEntry = (String, Value) - -type Label = String -type LabelType = Set Label - -labelsFromList :: [Label] -> LabelType -labelsFromList = Set.fromList - -data FuncType = FuncType PEnv String S.Type S.Type - deriving Eq - -instance Show FuncType where - show (FuncType _ s t1 t2) = "FuncType " ++ show s ++ " " ++ show t1 ++ " " ++ show t2 - -data NetworkAddress = NetworkAddress {hostname :: String, port :: String} - deriving (Eq, Show) - -type ActiveConnections = Map.Map NetworkAddress Handle - -type ServerSocket = (MVar.MVar (Map.Map String (NCon.NetworkConnection Value)), MVar.MVar [(String, Type)], String) - -type ValueRepr = String - --- | (Unit, Label, Int, Values of self-declared Data Types), Channels -data Value - = VUnit - | VLabel String - | VInt Int - | VDouble Double - | VString String - | VChan (NCon.NetworkConnection Value) (MVar.MVar (Map.Map String (NCon.NetworkConnection Value))) (MVar.MVar Bool) --Maybe a "used" mvar to notify that this vchan should no longer be used - -- This is exclusively used to add VChanSerials into the map when in the interpreter - -- This is to mark a vchan as used (true if used) - | VChanSerial ([Value], Int) ([Value], Int) String String (String, String) - | VSend Value - | VPair Value Value -- pair of ids that map to two values - | VType S.Type - | VFunc PEnv String Exp - | VDynCast Value GType -- (Value : G => *) - | VFuncCast Value FuncType FuncType -- (Value : (ρ,α,Π(x:A)A') => (ρ,α,Π(x:B)B')) - | VRec PEnv String String Exp Exp - | VNewNatRec PEnv String String String Type Exp String Exp - | VServerSocket (MVar.MVar (Map.Map String (NCon.NetworkConnection Value))) (MVar.MVar [(String, Type)]) String - -- Own Port Number - deriving Eq - --- disableOldVChan v = return v --- disableVChan v = return v --- disableVChans v = return v - -{- -disableOldVChan :: Value -> IO Value -disableOldVChan value = case value of - VChan nc mvar -> do - ncmap <- MVar.takeMVar mvar - constate <- MVar.newEmptyMVar - oldconstate <- MVar.takeMVar $ NCon.ncConnectionState nc - MVar.putMVar constate oldconstate - MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected - let newNC = NCon.NetworkConnection (NCon.ncRead nc) (NCon.ncWrite nc) (NCon.ncPartnerUserID nc) (NCon.ncOwnUserID nc) constate (NCon.ncRecievedRequestClose nc) - MVar.putMVar mvar $ Map.insert (Data.Maybe.fromMaybe "" (NCon.ncPartnerUserID nc)) newNC ncmap - return $ VChan newNC mvar - _ -> return value --} - -disableOldVChan :: Value -> IO Value -disableOldVChan value = case value of - VChan nc mvar used -> do - _ <- MVar.takeMVar used - MVar.putMVar used True - unused <- MVar.newEmptyMVar - MVar.putMVar unused False - return $ VChan nc mvar unused - _ -> return value - - -disableVChan :: Value -> IO () -disableVChan value = case value of - VChan nc mvar _ -> do - mbystate <- MVar.tryTakeMVar $ NCon.ncConnectionState nc --I dont fully understand why this mvar isnt filled but lets bypass this problem - case mbystate of - Nothing -> MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected - Just state -> case state of - NCon.Connected _ _ -> MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected - NCon.Emulated -> MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected - _ -> MVar.putMVar (NCon.ncConnectionState nc) state - _ -> return () - - - -disableVChans :: Value -> IO () -disableVChans input = case input of - VSend v -> do - nv <- disableVChans v - return () - -- return $ VSend nv - VPair v1 v2 -> do - nv1 <- disableVChans v1 - nv2 <- disableVChans v2 - return () - -- return $ VPair nv1 nv2 - VFunc penv a b -> do - newpenv <- disableVChansPEnv penv - return () - -- return $ VFunc newpenv a b - VDynCast v g -> do - nv <- disableVChans v - return () - -- return $ VDynCast nv g - VFuncCast v a b -> do - nv <- disableVChans v - return () - -- return $ VFuncCast nv a b - VRec penv a b c d -> do - newpenv <- disableVChansPEnv penv - return () - -- return $ VRec newpenv a b c d - VNewNatRec penv a b c d e f g -> do - newpenv <- disableVChansPEnv penv - return () - -- return $ VNewNatRec newpenv a b c d e f g - _ -> disableVChan input -- This handles vchans and the default case - where - disableVChansPEnv :: [(String, Value)] -> IO () - disableVChansPEnv [] = return () - disableVChansPEnv (x:xs) = do - newval <- disableVChans $ snd x - rest <- disableVChansPEnv xs - return () - -- return $ (fst x, newval):rest - - -instance Show Value where - show = \case - VUnit -> "VUnit" - VLabel s -> "VLabel " ++ s - VInt i -> "VInt " ++ show i - VDouble d -> "VDouble " ++ show d - VString s -> "VString \"" ++ show s ++ "\"" - VChan {} -> "VChan" - VChanSerial {} -> "VChanSerial" - VSend v -> "VSend (" ++ show v ++ ")" - VPair a b -> "VPair <" ++ show a ++ ", " ++ show b ++ ">" - VType t -> "VType " ++ show t - VFunc _ s exp -> "VFunc " ++ show s ++ " " ++ show exp - VDynCast v t -> "VDynCast (" ++ show v ++ ") (" ++ show t ++ ")" - VFuncCast v ft1 ft2 -> "VFuncCast (" ++ show v ++ ") (" ++ show ft1 ++ ") (" ++ show ft2 ++ ")" - VRec env f x e1 e0 -> "VRec " ++ " " ++ f ++ " " ++ x ++ " " ++ show e1 ++ " " ++ show e0 - VNewNatRec env f n tid ty ez x es -> "VNewNatRec " ++ f ++ n ++ tid ++ show ty ++ show ez ++ x ++ show es - VServerSocket {} -> "VServerSocket" - -class Subtypeable t where - isSubtypeOf :: t -> t -> Bool - --- Types in Head Normal Form -data NFType - = NFBot - | NFDyn - | NFFunc FuncType -- (ρ, α, Π(x: A) B) - | NFPair FuncType -- (ρ, α, Σ(x: A) B) - | NFGType GType -- every ground type is also a type in normal form - deriving (Show, Eq) - -instance Subtypeable NFType where - -- NFFunc and NFPair default to false, which is not really correct. - -- Implementation would be quite complicated and its not necessary, - -- i.e. not used anywhere. - isSubtypeOf NFBot _ = True - isSubtypeOf NFDyn NFDyn = True - isSubtypeOf (NFGType gt1) (NFGType gt2) = gt1 `isSubtypeOf` gt2 - isSubtypeOf _ _ = False - -data GType - = GUnit - | GLabel LabelType - | GFunc Multiplicity -- Π(x: *) * - | GPair -- Σ(x: *) * - | GNat - | GNatLeq Integer - | GInt - | GDouble - | GString - deriving (Show, Eq) - -instance Subtypeable GType where - isSubtypeOf GUnit GUnit = True - isSubtypeOf (GLabel ls1) (GLabel ls2) = ls1 `Set.isSubsetOf` ls2 - isSubtypeOf (GFunc _) (GFunc _) = True - isSubtypeOf (GPair) (GPair) = True - isSubtypeOf GNat GNat = True - isSubtypeOf (GNatLeq _) GNat = True - isSubtypeOf (GNatLeq n1) (GNatLeq n2) = n1 <= n2 - isSubtypeOf GInt GInt = True - isSubtypeOf GDouble GDouble = True - isSubtypeOf GString GString = True - isSubtypeOf _ _ = False +-- type InterpretM a = T.ReaderT (PEnv, (MVar.MVar (Map.Map Int ServerSocket), MVar.MVar ActiveConnections)) IO a +type InterpretM a = T.ReaderT (PEnv, (MVar.MVar (Map.Map Int ServerSocket), NMC.ActiveConnections)) IO a \ No newline at end of file diff --git a/src/ProcessEnvironmentTypes.hs b/src/ProcessEnvironmentTypes.hs new file mode 100644 index 0000000..f82c477 --- /dev/null +++ b/src/ProcessEnvironmentTypes.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE LambdaCase #-} +module ProcessEnvironmentTypes where +import Syntax as S +import GHC.IO.Handle +import Control.Concurrent.Chan as C +import Control.Concurrent.MVar as MVar +import Control.Monad.Reader as T +import Data.Set (Set) +import Data.Map as Map +import qualified Data.Set as Set +import Kinds (Multiplicity(..)) + +import qualified Data.Maybe + +import Networking.DirectionalConnection +import qualified Networking.NetworkConnection as NCon +-- import qualified Networking.Common as NC + +import Network.Socket + +extendEnv :: String -> Value -> PEnv -> PEnv +extendEnv = curry (:) + +-- | a Process Envronment maps identifiers to Values of expressions and stores +type PEnv = [PEnvEntry] +type PEnvEntry = (String, Value) + +type Label = String +type LabelType = Set Label + +labelsFromList :: [Label] -> LabelType +labelsFromList = Set.fromList + +data FuncType = FuncType PEnv String S.Type S.Type + deriving Eq + +instance Show FuncType where + show (FuncType _ s t1 t2) = "FuncType " ++ show s ++ " " ++ show t1 ++ " " ++ show t2 + +-- data NetworkAddress = NetworkAddress {hostname :: String, port :: String} +-- deriving (Eq, Show) + +type ServerSocket = (MVar.MVar (Map.Map String (NCon.NetworkConnection Value)), MVar.MVar [(String, Type)], String) + +type ValueRepr = String + +-- | (Unit, Label, Int, Values of self-declared Data Types), Channels +data Value + = VUnit + | VLabel String + | VInt Int + | VDouble Double + | VString String + | VChan (NCon.NetworkConnection Value) (MVar.MVar (Map.Map String (NCon.NetworkConnection Value))) (MVar.MVar Bool) --Maybe a "used" mvar to notify that this vchan should no longer be used + -- This is exclusively used to add VChanSerials into the map when in the interpreter + -- This is to mark a vchan as used (true if used) + | VChanSerial ([Value], Int) ([Value], Int) String String (String, String) + | VSend Value + | VPair Value Value -- pair of ids that map to two values + | VType S.Type + | VFunc PEnv String Exp + | VDynCast Value GType -- (Value : G => *) + | VFuncCast Value FuncType FuncType -- (Value : (ρ,α,Π(x:A)A') => (ρ,α,Π(x:B)B')) + | VRec PEnv String String Exp Exp + | VNewNatRec PEnv String String String Type Exp String Exp + | VServerSocket (MVar.MVar (Map.Map String (NCon.NetworkConnection Value))) (MVar.MVar [(String, Type)]) String + -- Own Port Number + deriving Eq + +disableOldVChan :: Value -> IO Value +disableOldVChan value = case value of + VChan nc mvar used -> do + _ <- MVar.takeMVar used + MVar.putMVar used True + unused <- MVar.newEmptyMVar + MVar.putMVar unused False + return $ VChan nc mvar unused + _ -> return value + + +disableVChan :: Value -> IO () +disableVChan value = case value of + VChan nc mvar _ -> do + mbystate <- MVar.tryTakeMVar $ NCon.ncConnectionState nc --I dont fully understand why this mvar isnt filled but lets bypass this problem + case mbystate of + Nothing -> MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected + Just state -> case state of + NCon.Connected _ _ -> MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected + NCon.Emulated -> MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected + _ -> MVar.putMVar (NCon.ncConnectionState nc) state + _ -> return () + + + +disableVChans :: Value -> IO () +disableVChans input = case input of + VSend v -> do + nv <- disableVChans v + return () + -- return $ VSend nv + VPair v1 v2 -> do + nv1 <- disableVChans v1 + nv2 <- disableVChans v2 + return () + -- return $ VPair nv1 nv2 + VFunc penv a b -> do + newpenv <- disableVChansPEnv penv + return () + -- return $ VFunc newpenv a b + VDynCast v g -> do + nv <- disableVChans v + return () + -- return $ VDynCast nv g + VFuncCast v a b -> do + nv <- disableVChans v + return () + -- return $ VFuncCast nv a b + VRec penv a b c d -> do + newpenv <- disableVChansPEnv penv + return () + -- return $ VRec newpenv a b c d + VNewNatRec penv a b c d e f g -> do + newpenv <- disableVChansPEnv penv + return () + -- return $ VNewNatRec newpenv a b c d e f g + _ -> disableVChan input -- This handles vchans and the default case + where + disableVChansPEnv :: [(String, Value)] -> IO () + disableVChansPEnv [] = return () + disableVChansPEnv (x:xs) = do + newval <- disableVChans $ snd x + rest <- disableVChansPEnv xs + return () + -- return $ (fst x, newval):rest + + +instance Show Value where + show = \case + VUnit -> "VUnit" + VLabel s -> "VLabel " ++ s + VInt i -> "VInt " ++ show i + VDouble d -> "VDouble " ++ show d + VString s -> "VString \"" ++ show s ++ "\"" + VChan {} -> "VChan" + VChanSerial {} -> "VChanSerial" + VSend v -> "VSend (" ++ show v ++ ")" + VPair a b -> "VPair <" ++ show a ++ ", " ++ show b ++ ">" + VType t -> "VType " ++ show t + VFunc _ s exp -> "VFunc " ++ show s ++ " " ++ show exp + VDynCast v t -> "VDynCast (" ++ show v ++ ") (" ++ show t ++ ")" + VFuncCast v ft1 ft2 -> "VFuncCast (" ++ show v ++ ") (" ++ show ft1 ++ ") (" ++ show ft2 ++ ")" + VRec env f x e1 e0 -> "VRec " ++ " " ++ f ++ " " ++ x ++ " " ++ show e1 ++ " " ++ show e0 + VNewNatRec env f n tid ty ez x es -> "VNewNatRec " ++ f ++ n ++ tid ++ show ty ++ show ez ++ x ++ show es + VServerSocket {} -> "VServerSocket" + +class Subtypeable t where + isSubtypeOf :: t -> t -> Bool + +-- Types in Head Normal Form +data NFType + = NFBot + | NFDyn + | NFFunc FuncType -- (ρ, α, Π(x: A) B) + | NFPair FuncType -- (ρ, α, Σ(x: A) B) + | NFGType GType -- every ground type is also a type in normal form + deriving (Show, Eq) + +instance Subtypeable NFType where + -- NFFunc and NFPair default to false, which is not really correct. + -- Implementation would be quite complicated and its not necessary, + -- i.e. not used anywhere. + isSubtypeOf NFBot _ = True + isSubtypeOf NFDyn NFDyn = True + isSubtypeOf (NFGType gt1) (NFGType gt2) = gt1 `isSubtypeOf` gt2 + isSubtypeOf _ _ = False + +data GType + = GUnit + | GLabel LabelType + | GFunc Multiplicity -- Π(x: *) * + | GPair -- Σ(x: *) * + | GNat + | GNatLeq Integer + | GInt + | GDouble + | GString + deriving (Show, Eq) + +instance Subtypeable GType where + isSubtypeOf GUnit GUnit = True + isSubtypeOf (GLabel ls1) (GLabel ls2) = ls1 `Set.isSubsetOf` ls2 + isSubtypeOf (GFunc _) (GFunc _) = True + isSubtypeOf (GPair) (GPair) = True + isSubtypeOf GNat GNat = True + isSubtypeOf (GNatLeq _) GNat = True + isSubtypeOf (GNatLeq n1) (GNatLeq n2) = n1 <= n2 + isSubtypeOf GInt GInt = True + isSubtypeOf GDouble GDouble = True + isSubtypeOf GString GString = True + isSubtypeOf _ _ = False diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 483059f..1c4b63f 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -7,7 +7,7 @@ import qualified Data.Set as Set import Kinds import Syntax -import ProcessEnvironment +import ProcessEnvironmentTypes import ValueParsing.ValueTokens (T(..)) import qualified ValueParsing.ValueTokens as T import Networking.Messages diff --git a/test/CSpec.hs b/test/CSpec.hs index 4d041ef..da47b96 100644 --- a/test/CSpec.hs +++ b/test/CSpec.hs @@ -22,7 +22,8 @@ import C.Compile as C import C.Generate import Interpreter (interpret) import Parsing -import ProcessEnvironment (Value(..)) +import ProcessEnvironment +import ProcessEnvironmentTypes import Typechecker (typecheck, Options(..)) import qualified Examples diff --git a/test/InterpreterSpec.hs b/test/InterpreterSpec.hs index eda367d..399776e 100644 --- a/test/InterpreterSpec.hs +++ b/test/InterpreterSpec.hs @@ -7,6 +7,7 @@ import Kinds import Syntax import Interpreter import ProcessEnvironment +import ProcessEnvironmentTypes import UtilsFuncCcldlc spec :: Spec diff --git a/test/Utils.hs b/test/Utils.hs index 2f8bbe6..09287d1 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -4,6 +4,9 @@ import Parsing import Syntax import Interpreter import ProcessEnvironment +import ProcessEnvironmentTypes +import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC +import qualified Networking.NetworkingMethod.Stateless as Stateless import Control.Monad.Reader (runReaderT) import Test.Hspec import Control.Concurrent.MVar @@ -21,9 +24,8 @@ raiseFailure msg = do shouldInterpretTo :: [Decl] -> Value -> Expectation shouldInterpretTo givenDecls expectedValue = do sockets <- newEmptyMVar - handles <- newEmptyMVar + handles <- Stateless.createActiveConnections putMVar sockets Map.empty - putMVar handles Map.empty value <- runReaderT (interpretDecl givenDecls) ([], (sockets, handles)) value `shouldBe` expectedValue @@ -34,24 +36,21 @@ shouldThrowCastException givenDecls = isCastException _ = False in do sockets <- newEmptyMVar - handles <- newEmptyMVar + handles <- Stateless.createActiveConnections putMVar sockets Map.empty - putMVar handles Map.empty runReaderT (interpretDecl givenDecls) ([], (sockets, handles)) `shouldThrow` isCastException shouldThrowInterpreterException :: Decl -> InterpreterException -> Expectation shouldThrowInterpreterException given except = do sockets <- newEmptyMVar - handles <- newEmptyMVar + handles <- Stateless.createActiveConnections putMVar sockets Map.empty - putMVar handles Map.empty runReaderT (interpretDecl [given]) ([], (sockets, handles)) `shouldThrow` (== except) shouldInterpretTypeTo :: Type -> NFType -> Expectation shouldInterpretTypeTo t expected = do sockets <- newEmptyMVar - handles <- newEmptyMVar + handles <- Stateless.createActiveConnections putMVar sockets Map.empty - putMVar handles Map.empty nft <- runReaderT (evalType t) ([], (sockets, handles)) nft `shouldBe` expected From fef433213859e818ca0ff42ca58b174b761dffc5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 30 Jan 2023 16:05:58 +0100 Subject: [PATCH 088/229] Stateless implementet in new design, still buggy --- src/Interpreter.hs | 57 +++--- src/Networking/Client.hs | 123 ++++++++----- src/Networking/Common.hs | 27 ++- src/Networking/NetworkingMethod/Fast.hs | 13 +- src/Networking/NetworkingMethod/Stateless.hs | 104 +++++++---- src/Networking/Server.hs | 181 +++++++------------ 6 files changed, 272 insertions(+), 233 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 3610bba..2be4284 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -58,7 +58,8 @@ import qualified Control.Concurrent as MVar -- import qualified Networking.NetworkConnection as NCon -- import qualified Networking.NetworkConnection as NCon -import qualified Networking.NetworkingMethod.Stateless as NetMethod +import qualified Data.Bifunctor +-- import qualified Networking.NetworkingMethod.Stateless as NetMethod -- import qualified Networking.NetworkingMethod.Fast as NetMethod data InterpreterException @@ -98,19 +99,19 @@ blame exp = throw $ CastException exp -- | interpret the "main" value in an ldgv file given over stdin interpret :: [Decl] -> IO Value -interpret decls = do +interpret decls = do sockets <- MVar.newEmptyMVar - activeConnections <- NetMethod.createActiveConnections + activeConnections <- NC.createActiveConnections MVar.putMVar sockets Map.empty R.runReaderT (interpretDecl decls) ([], (sockets, activeConnections)) interpretDecl :: [Decl] -> InterpretM Value interpretDecl (DFun "main" _ e _:_) = interpret' e -interpretDecl (DFun name [] e _:decls) = interpret' e >>= \v -> local (\(env, sock) -> ((extendEnv name v) env, sock)) (interpretDecl decls) +interpretDecl (DFun name [] e _:decls) = interpret' e >>= \v -> local (Data.Bifunctor.first (extendEnv name v)) (interpretDecl decls) interpretDecl (DFun name binds e _:decls) = let lambda = foldr (\(mul, id, ty) -> Lam mul id ty) e binds - in interpret' lambda >>= \v -> local (\(env, sock) -> ((extendEnv name v) env, sock)) (interpretDecl decls) -interpretDecl (DType name _ _ t:decls) = local (\(env, sock) -> ((extendEnv name $ VType t) env, sock)) (interpretDecl decls) + in interpret' lambda >>= \v -> local (Data.Bifunctor.first (extendEnv name v)) (interpretDecl decls) +interpretDecl (DType name _ _ t:decls) = local (Data.Bifunctor.first (extendEnv name $ VType t)) (interpretDecl decls) interpretDecl (_:decls) = interpretDecl decls interpretDecl [] = throw $ LookupException "main" @@ -136,13 +137,13 @@ eval = \case VInt 0 -> interpret' e2 VInt 1 -> do zero <- interpret' e2 - R.local (\(env, sock) -> ((extendEnv i1 (VInt 0) . extendEnv i2 zero) env, sock)) (interpret' e3) + R.local (Data.Bifunctor.first (extendEnv i1 (VInt 0) . extendEnv i2 zero)) (interpret' e3) VInt n -> do -- interpret the n-1 case i2 and add it to the env -- together with n before interpreting the body e3 let lowerEnv = extendEnv i1 (VInt $ n-1) - lower <- R.local (\(env,sock) -> (lowerEnv env, sock)) (interpret' $ NatRec (Var i1) e2 i1 t1 i2 t e3) - R.local (\(env, sock) -> ((extendEnv i2 lower . lowerEnv) env, sock)) (interpret' e3) + lower <- R.local (Data.Bifunctor.first lowerEnv) (interpret' $ NatRec (Var i1) e2 i1 t1 i2 t e3) + R.local (Data.Bifunctor.first (extendEnv i2 lower . lowerEnv)) (interpret' e3) _ -> throw $ RecursorException "Evaluation of 'natrec x...' must yield Nat value" NewNatRec f n tid ty ez x es -> ask >>= \(env, _) -> return $ VNewNatRec env f n tid ty ez x es Lam _ i _ e -> ask >>= \(env, sock) -> return $ VFunc env i e @@ -162,7 +163,7 @@ eval = \case maybe (blame cast) return v' _ -> let v' = reduceCast v nft1 nft2 in maybe (blame cast) return v' Var s -> ask >>= \(env, _) -> maybe (throw $ LookupException s) (liftIO . pure) (lookup s env) - Let s e1 e2 -> interpret' e1 >>= \v -> R.local (\(env, sock) -> ((extendEnv s v env), sock)) (interpret' e2) + Let s e1 e2 -> interpret' e1 >>= \v -> R.local (Data.Bifunctor.first (extendEnv s v)) (interpret' e2) Math m -> interpretMath m Lit l -> return (interpretLit l) e@(App e1 e2) -> do @@ -172,9 +173,9 @@ eval = \case interpretApp e val arg Pair mul s e1 e2 -> do v1 <- interpret' e1 - v2 <- R.local (\(env, sock) -> ((extendEnv s v1 env), sock)) (interpret' e2) + v2 <- R.local (Data.Bifunctor.first (extendEnv s v1)) (interpret' e2) return $ VPair v1 v2 - LetPair s1 s2 e1 e2 -> interpret' e1 >>= \(VPair v1 v2) -> R.local (\(env, sock) -> ((extendEnv s2 v2 . extendEnv s1 v1) env, sock)) (interpret' e2) + LetPair s1 s2 e1 e2 -> interpret' e1 >>= \(VPair v1 v2) -> R.local (Data.Bifunctor.first (extendEnv s2 v2 . extendEnv s1 v1)) (interpret' e2) fst@(Fst e) -> interpret' e >>= \(VPair s1 s2) -> return s1 snd@(Snd e) -> interpret' e >>= \(VPair s1 s2) -> return s2 Fork e -> do @@ -202,7 +203,8 @@ eval = \case if used then throw $ VChanIsUsedException $ show v else do let dcRead = NCon.ncRead ci valunclean <- liftIO $ DC.readUnreadMessage dcRead - val <- liftIO $ NS.replaceVChanSerial mvar valunclean + (env, (sockets, activeConnections)) <- ask + val <- liftIO $ NS.replaceVChanSerial activeConnections mvar valunclean liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e -- Disable the old channel and get a new one @@ -220,17 +222,18 @@ eval = \case _ <- liftIO $ disableOldVChan v return v Case e cases -> interpret' e >>= \(VLabel s) -> interpret' $ fromJust $ lookup s cases - Create e -> do + {- Create e -> do liftIO $ C.traceIO "Creating socket!" val <- interpret' e case val of VInt port -> do - (mvar, clientlist) <- liftIO $ NS.createServer port + (_, (_, activeConnections)) <- ask + (mvar, clientlist) <- liftIO $ NetMethod.acceptConversations activeConnections NS.handleClient port liftIO $ C.traceIO "Socket created" return $ VServerSocket mvar clientlist $ show port _ -> throw $ NotAnExpectedValueException "VInt" val - + -} Accept e t -> do liftIO $ C.traceIO "Accepting new client!" @@ -238,7 +241,7 @@ eval = \case case val of VInt port -> do (env, (sockets, activeConnections)) <- ask - (mvar, clientlist, ownport) <- liftIO $ NS.ensureSocket port sockets + (mvar, clientlist, ownport) <- liftIO $ NC.acceptConversations activeConnections NS.handleClient port sockets -- newuser <- liftIO $ Chan.readChan chan liftIO $ C.traceIO "Searching for correct communicationpartner" newuser <- liftIO $ NS.findFittingClient clientlist t -- There is still an issue @@ -246,7 +249,7 @@ eval = \case networkconnectionmap <- liftIO $ MVar.readMVar mvar case Map.lookup newuser networkconnectionmap of Nothing -> throw $ CommunicationPartnerNotFoundException newuser - Just networkconnection -> do + Just networkconnection -> do liftIO $ C.traceIO "Client successfully accepted!" used <- liftIO MVar.newEmptyMVar liftIO $ MVar.putMVar used False @@ -257,19 +260,18 @@ eval = \case r <- liftIO DC.newConnection w <- liftIO DC.newConnection liftIO $ C.traceIO "Client trying to connect" - val <- interpret' e0 case val of VInt port -> do (env, (sockets, activeConnections)) <- ask - (networkconmapmvar, chan, ownport) <- liftIO $ NS.ensureSocket port sockets + (networkconmapmvar, chan, ownport) <- liftIO $ NC.acceptConversations activeConnections NS.handleClient port sockets addressVal <- interpret' e1 case addressVal of VString address -> do portVal <- interpret' e2 case portVal of VInt port -> do - liftIO $ NClient.initialConnect networkconmapmvar address (show port) ownport t + liftIO $ NClient.initialConnect activeConnections networkconmapmvar address (show port) ownport t _ -> throw $ NotAnExpectedValueException "VInt" portVal _ -> throw $ NotAnExpectedValueException "VString" addressVal _ -> throw $ NotAnExpectedValueException "VInt" val @@ -277,7 +279,7 @@ eval = \case -- Exp is only used for blame interpretApp :: Exp -> Value -> Value -> InterpretM Value -interpretApp _ (VFunc env s exp) w = R.local (\(cenv, sock) -> ((const $ extendEnv s w env) cenv, sock)) (interpret' exp) +interpretApp _ (VFunc env s exp) w = R.local (Data.Bifunctor.first (const $ extendEnv s w env)) (interpret' exp) interpretApp e (VFuncCast v (FuncType penv s t1 t2) (FuncType penv' s' t1' t2')) w' = do (env0, socketMVar) <- ask let @@ -288,7 +290,7 @@ interpretApp e (VFuncCast v (FuncType penv s t1 t2) (FuncType penv' s' t1' t2')) nft1' <- R.runReaderT (evalType t1') (penv', socketMVar) w <- maybe (blame e) return (reduceCast w' nft1' nft1) nft2' <- R.runReaderT (evalType t2') (extendEnv s' w' penv', socketMVar) - nft2 <- R.runReaderT (evalType t2) (extendEnv s w penv, socketMVar) + nft2 <- R.runReaderT (evalType t2) (extendEnv s w penv, socketMVar) u <- R.runReaderT (interpretApp e v w) (env0, socketMVar) u' <- maybe (blame e) return (reduceCast u nft2 nft2') C.traceIO ("Function cast in application results in: " ++ show u') @@ -299,18 +301,19 @@ interpretApp e rec@(VRec env f n1 e1 e0) (VInt n) | n == 0 = interpret' e0 | n > 0 = do let env' = extendEnv n1 (VInt (n-1)) (extendEnv f rec env) - R.local (\(env,sock) -> ((const env') env, sock)) (interpret' e1) + R.local (Data.Bifunctor.first (const env')) (interpret' e1) interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) | n < 0 = throw RecursorNotNatException | n == 0 = interpret' ez | n > 0 = do let env' = extendEnv n1 (VInt (n-1)) (extendEnv f natrec env) - R.local (\(env,sock) -> ((const env') env, sock)) (interpret' es) + R.local (Data.Bifunctor.first (const env')) (interpret' es) -- interpretApp _ (VSend v@(VChan _ c handle _ _ _)) w = do interpretApp _ (VSend v@(VChan cc _ usedmvar)) w = do used <- liftIO $ MVar.readMVar usedmvar if used then throw $ VChanIsUsedException $ show v else do - liftIO $ NClient.sendValue cc w (-1) + (env, (sockets, activeConnections)) <- ask + liftIO $ NClient.sendValue activeConnections cc w (-1) -- Disable old VChan newV <- liftIO $ disableOldVChan v @@ -365,7 +368,7 @@ evalType = \case else let lower = TNatRec (Lit $ LNat (n-1)) t1 tid t2 in do - R.local (\(env, sock) -> (extendEnv tid (VType lower) env, sock)) (evalType t2) + R.local (Data.Bifunctor.first (extendEnv tid (VType lower))) (evalType t2) _ -> throw $ RecursorException "Evaluation of 'natrec x...' must yield Nat value" TName _ s -> ask >>= \(env, _) -> maybe (throw $ LookupException s) (\(VType t) -> evalType t) (lookup s env) TLab ls -> return $ NFGType $ GLabel $ labelsFromList ls diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index f6052ea..fa1fc4c 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -29,6 +29,7 @@ import qualified Control.Concurrent as MVar import qualified Config import qualified Networking.Serialize as NSerialize import Control.Monad +import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC newtype ClientException = NoIntroductionException String @@ -41,8 +42,8 @@ instance Show ClientException where instance Exception ClientException -sendValue :: NetworkConnection Value -> Value -> Int -> IO () -sendValue networkconnection val resendOnError = do +sendValue :: NMC.ActiveConnections -> NetworkConnection Value -> Value -> Int -> IO () +sendValue activeCons networkconnection val resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port -> do @@ -51,30 +52,31 @@ sendValue networkconnection val resendOnError = do DC.writeMessage (ncWrite networkconnection) valcleaned messagesCount <- DC.countMessages $ ncWrite networkconnection -- catch (tryToSend networkconnection hostname port val valcleaned) $ printConErr hostname port - catch (do - tryToSendNetworkMessage networkconnection hostname port (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) messagesCount valcleaned) resendOnError + catch (do + tryToSendNetworkMessage activeCons networkconnection hostname port (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) messagesCount valcleaned) resendOnError disableVChans val ) $ printConErr hostname port NCon.Emulated -> DC.writeMessage (ncWrite networkconnection) val _ -> Config.traceNetIO "Error when sending message: This channel is disconnected" -- MVar.putMVar (ncConnectionState networkconnection) connectionstate -sendNetworkMessage :: NetworkConnection Value -> Messages -> Int -> IO () -sendNetworkMessage networkconnection message resendOnError = do +sendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> Messages -> Int -> IO () +sendNetworkMessage activeCons networkconnection message resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port -> do - catch ( tryToSendNetworkMessage networkconnection hostname port message resendOnError) $ printConErr hostname port + catch ( tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError) $ printConErr hostname port NCon.Emulated -> pure () _ -> Config.traceNetIO "Error when sending message: This channel is disconnected" --MVar.putMVar (ncConnectionState networkconnection) connectionstate -tryToSendNetworkMessage :: NetworkConnection Value -> String -> String -> Messages -> Int -> IO () -tryToSendNetworkMessage networkconnection hostname port message resendOnError = do +tryToSendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> String -> String -> Messages -> Int -> IO () +tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError = do serializedMessage <- NSerialize.serialize message Config.traceNetIO $ "Sending message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection) ++ " to: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkconnection) Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port Config.traceNetIO $ " Message: " ++ serializedMessage + {- let hints = defaultHints { addrFamily = AF_INET , addrFlags = [] @@ -104,6 +106,17 @@ tryToSendNetworkMessage networkconnection hostname port message resendOnError = MVar.putMVar response mbyresponse ) mbyresponse <- getResp threadid connectionsuccessful response 10 + -} + + + mbycon <- NC.startConversation activeCons hostname port 10000 100 + mbyresponse <- case mbycon of + Just con -> do + NC.sendMessage con message + potentialResponse <- NC.recieveResponse con 10000 100 + NC.endConversation con 10000 10 + return potentialResponse + Nothing -> return Nothing case mbyresponse of Just response -> case response of @@ -116,27 +129,28 @@ tryToSendNetworkMessage networkconnection hostname port message resendOnError = Redirect host port -> do Config.traceNetIO "Communication partner changed address, resending" NCon.changePartnerAddress networkconnection host port - tryToSendNetworkMessage networkconnection host port message resendOnError + tryToSendNetworkMessage activeCons networkconnection host port message resendOnError Wait -> do Config.traceNetIO "Communication out of sync lets wait!" threadDelay 1000000 - tryToSendNetworkMessage networkconnection hostname port message resendOnError + tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError _ -> Config.traceNetIO "Unknown communication error" - Nothing -> do + Nothing -> do Config.traceNetIO "Error when recieving response" connectionstate <- MVar.readMVar $ ncConnectionState networkconnection - connectedToPeer <- MVar.readMVar connectionsuccessful - unless connectedToPeer $ Config.traceNetIO "Not connected to peer" + -- connectedToPeer <- MVar.readMVar connectionsuccessful + when (Data.Maybe.isNothing mbycon) $ Config.traceNetIO "Not connected to peer" Config.traceNetIO $ "Original message: " ++ serializedMessage case connectionstate of - NCon.Connected newhostname newport -> if resendOnError /= 0 && connectedToPeer then do + NCon.Connected newhostname newport -> if resendOnError /= 0 then do Config.traceNetIO $ "Old communication partner offline! New communication partner: " ++ newhostname ++ ":" ++ newport threadDelay 1000000 - tryToSendNetworkMessage networkconnection newhostname newport message $ max (resendOnError-1) (-1) + tryToSendNetworkMessage activeCons networkconnection newhostname newport message $ max (resendOnError-1) (-1) else Config.traceNetIO "Old communication partner offline! No longer retrying" _ -> Config.traceNetIO "Error when sending message: This channel is disconnected while sending" +{- where getResp :: ThreadId -> MVar.MVar Bool -> MVar.MVar (Maybe Responses) -> Int -> IO (Maybe Responses) getResp threadid connectedmvar mbyResponse count = do @@ -152,34 +166,55 @@ tryToSendNetworkMessage networkconnection hostname port message resendOnError = else do killThread threadid return Nothing - +-} printConErr :: String -> String -> IOException -> IO () printConErr hostname port err = Config.traceIO $ "Communication Partner " ++ hostname ++ ":" ++ port ++ "not found!" -initialConnect :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> Syntax.Type -> IO Value -initialConnect mvar hostname port ownport syntype= do - handle <- getClientHandle hostname port - ownuserid <- UserID.newRandomUserID - Config.traceIO "Client connected: Introducing" - NC.sendMessage (Messages.IntroduceClient ownuserid ownport syntype) handle - introductionanswer <- waitForServerIntroduction handle - Config.traceIO "Finished Handshake" +initialConnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> Syntax.Type -> IO Value +initialConnect activeCons mvar hostname port ownport syntype= do + -- handle <- getClientHandle hostname port + mbycon <- NC.waitForConversation activeCons hostname port 10000 100 - msgserial <- NSerialize.serialize $ Messages.IntroduceClient ownuserid ownport syntype - Config.traceNetIO $ "Sending message as: " ++ ownuserid ++ " to: " ++ introductionanswer - Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port - Config.traceNetIO $ " Message: " ++ msgserial - hClose handle + case mbycon of + Just con -> do + ownuserid <- UserID.newRandomUserID + Config.traceIO "Client connected: Introducing" + NC.sendMessage con (Messages.IntroduceClient ownuserid ownport syntype) + mbyintroductionanswer <- NC.recieveResponse con 10000 (-1) + NC.endConversation con 10000 10 + case mbyintroductionanswer of + Just introduction -> case introduction of + OkayIntroduce introductionanswer -> do + Config.traceIO "Finished Handshake" + msgserial <- NSerialize.serialize $ Messages.IntroduceClient ownuserid ownport syntype + Config.traceNetIO $ "Sending message as: " ++ ownuserid ++ " to: " ++ introductionanswer + Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port + Config.traceNetIO $ " Message: " ++ msgserial + newConnection <- newNetworkConnection introductionanswer ownuserid hostname port + networkconnectionmap <- MVar.takeMVar mvar + let newNetworkconnectionmap = Map.insert introductionanswer newConnection networkconnectionmap + MVar.putMVar mvar newNetworkconnectionmap + used <- MVar.newEmptyMVar + MVar.putMVar used False + return $ VChan newConnection mvar used + + _ -> do + introductionserial <- NSerialize.serialize introduction + Config.traceNetIO $ "Illegal answer from server: " ++ introductionserial + threadDelay 1000000 + initialConnect activeCons mvar hostname port ownport syntype + Nothing -> do + Config.traceNetIO "Something went wrong while connection to the server" + threadDelay 1000000 + initialConnect activeCons mvar hostname port ownport syntype + -- hClose handle + Nothing -> do + Config.traceNetIO "Couldn't connect to server. Retrying" + threadDelay 1000000 + initialConnect activeCons mvar hostname port ownport syntype - newConnection <- newNetworkConnection introductionanswer ownuserid hostname port - networkconnectionmap <- MVar.takeMVar mvar - let newNetworkconnectionmap = Map.insert introductionanswer newConnection networkconnectionmap - MVar.putMVar mvar newNetworkconnectionmap - used <- MVar.newEmptyMVar - MVar.putMVar used False - return $ VChan newConnection mvar used sendVChanMessages :: String -> String -> Value -> IO () sendVChanMessages newhost newport input = case input of @@ -199,7 +234,7 @@ sendVChanMessages newhost newport input = case input of Config.traceNetIO $ "Set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest newhost newport-} - + oldconnectionstate <- MVar.takeMVar $ ncConnectionState nc MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest (NCon.csHostname oldconnectionstate) (NCon.csPort oldconnectionstate) newhost newport -- tempnetcon <- NCon.newNetworkConnectionAllowingMaybe (NCon.ncPartnerUserID nc) (NCon.ncOwnUserID nc) (NCon.csHostname oldconnectionstate) (NCon.csPort oldconnectionstate) @@ -213,6 +248,10 @@ sendVChanMessages newhost newport input = case input of sendVChanMessages newhost newport $ snd x sendVChanMessagesPEnv newhost newport xs +closeConnection _ = return () + +-- Close Connection is no longer needed +{- closeConnection :: NetworkConnection Value -> IO () closeConnection con = do connectionstate <- MVar.readMVar $ ncConnectionState con @@ -236,8 +275,8 @@ closeConnection con = do closeConnection con NCon.Emulated -> pure () _ -> Config.traceIO "Error when sending message: This channel is disconnected" - - +-} +{- recieveResponse :: Handle -> IO (Maybe Responses) recieveResponse handle = do retVal <- MVar.newEmptyMVar @@ -274,7 +313,7 @@ getClientHandle hostname port = do expredirect hostname port e = do threadDelay 1000000 getClientHandle hostname port - +-} replaceVChan :: Value -> IO Value replaceVChan input = case input of VSend v -> do @@ -311,6 +350,7 @@ replaceVChan input = case input of rest <- replaceVChanPEnv xs return $ (fst x, newval):rest +{- waitForServerIntroduction :: Handle -> IO String waitForServerIntroduction handle = do NC.recieveMessage handle VG.parseResponses (throw . NoIntroductionException) deserHandler @@ -321,3 +361,4 @@ waitForServerIntroduction handle = do _ -> do Config.traceIO $ "Error during server introduction, wrong message: "++ message throw $ NoIntroductionException message +-} \ No newline at end of file diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index b5becef..b3c93a4 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -9,12 +9,28 @@ import qualified Networking.Serialize as NSerialize import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG import qualified Config +import qualified Networking.NetworkingMethod.Stateless as NetMethod -sendMessage :: NSerialize.Serializable a => a -> Handle -> IO () -sendMessage value handle = do - serializedValue <- NSerialize.serialize value - hPutStrLn handle (serializedValue ++" ") + +-- The compiler sadly compains when these things get eta reduced :/ +sendMessage con ser = NetMethod.sendMessage con ser + +sendResponse con ser = NetMethod.sendResponse con ser + +startConversation activeCons host port waitTime tries = NetMethod.startConversation activeCons host port waitTime tries + +waitForConversation activeCons host port waitTime tries = NetMethod.waitForConversation activeCons host port waitTime tries + +createActiveConnections = NetMethod.createActiveConnections + +acceptConversations activeCons connectionhandler port socketsmvar = NetMethod.acceptConversations activeCons connectionhandler port socketsmvar + +recieveResponse con waitTime tries = NetMethod.recieveResponse con waitTime tries + +endConversation con waitTime tries = NetMethod.endConversation con waitTime tries + +{- getHandle :: Socket -> IO Handle getHandle socket = do hdl <- socketToHandle socket ReadWriteMode @@ -33,4 +49,5 @@ recieveMessage handle grammar fallbackResponse messageHandler = do messageHandler message deserialmessage openSocketNC :: AddrInfo -> IO Socket -openSocketNC addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) \ No newline at end of file +openSocketNC addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) +-} \ No newline at end of file diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index 84b4b62..f25943c 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -30,17 +30,17 @@ type Conversation = (String, Handle, MVar.MVar (Map.Map String (String, Response -- type Connectionhandler = MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Messages -> IO () -sendMessage :: Messages -> Conversation -> IO () -sendMessage value conversation@(cid, handle, responses) = Stateless.sendMessage (ConversationMessage cid value) handle +sendMessage :: Conversation -> Messages -> IO () +sendMessage conversation@(cid, handle, responses) value = Stateless.sendMessage handle (ConversationMessage cid value) -sendResponse :: Responses -> Conversation -> IO () -sendResponse value conversation@(cid, handle, responses) = Stateless.sendResponse (ConversationResponse cid value) handle +sendResponse :: Conversation -> Responses -> IO () +sendResponse conversation@(cid, handle, responses) value = Stateless.sendResponse handle (ConversationResponse cid value) conversationHandler :: Handle -> IO Connection conversationHandler handle = do chan <- Chan.newChan mvar <- MVar.newEmptyMVar - forkIO $ forever $ Stateless.recieveMessage handle VG.parseConversation (\_ -> return ()) (\mes des -> case des of + forkIO $ forever $ Stateless.recieveMessageInternal handle VG.parseConversation (\_ -> return ()) (\mes des -> case des of ConversationMessage cid message -> Chan.writeChan chan (cid, (mes, message)) ConversationResponse cid response -> do mymap <- MVar.takeMVar mvar @@ -75,7 +75,8 @@ startConversation acmvar hostname port waitTime tries = do MVar.putMVar acmvar connectionMap return $ Just (conversationid, handle, mvar) Nothing -> do - mbyNewHandle <- Stateless.startConversation Nothing hostname port waitTime tries + statelessActiveCons <- Stateless.createActiveConnections + mbyNewHandle <- Stateless.startConversation statelessActiveCons hostname port waitTime tries case mbyNewHandle of Just handle -> do newconnection@(handle, chan, mvar) <- conversationHandler handle diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index 2735371..1a0337f 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -19,19 +19,19 @@ import qualified ValueParsing.ValueGrammar as VG import qualified Config import qualified Syntax -type ConnectionHandler = MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Messages -> IO () +type ConnectionHandler = ActiveConnectionsStateless -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Messages -> IO () -sendMessage :: NSerialize.Serializable a => a -> Handle -> IO () -sendMessage value handle = do +sendMessage :: NSerialize.Serializable a => Handle -> a -> IO () +sendMessage handle value = do serializedValue <- NSerialize.serialize value hPutStrLn handle (serializedValue ++" ") -sendResponse :: NSerialize.Serializable a => a -> Handle -> IO () +sendResponse :: NSerialize.Serializable a => Handle -> a -> IO () sendResponse = sendMessage -recieveMessage :: Handle -> VT.Alex t -> (String -> IO b) -> (String -> t -> IO b) -> IO b -recieveMessage handle grammar fallbackResponse messageHandler = do +recieveMessageInternal :: Handle -> VT.Alex t -> (String -> IO b) -> (String -> t -> IO b) -> IO b +recieveMessageInternal handle grammar fallbackResponse messageHandler = do message <- hGetLine handle case VT.runAlex message grammar of Left err -> do @@ -41,7 +41,7 @@ recieveMessage handle grammar fallbackResponse messageHandler = do -- Config.traceNetIO $ "New superficially valid message recieved: "++message messageHandler message deserialmessage -startConversation :: a -> String -> String -> Int -> Int -> IO (Maybe Handle) +startConversation :: ActiveConnectionsStateless -> String -> String -> Int -> Int -> IO (Maybe Handle) startConversation _ hostname port waitTime tries = do let hints = defaultHints { addrFamily = AF_INET @@ -59,39 +59,62 @@ startConversation _ hostname port waitTime tries = do ) getFromNetworkThread threadid handleMVar waitTime tries -acceptConversations :: a -> ConnectionHandler -> Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), MVar.MVar [(String, Syntax.Type)]) -acceptConversations _ connectionhandler port = do - -- serverid <- UserID.newRandomUserID - sock <- socket AF_INET Stream 0 - setSocketOption sock ReuseAddr 1 - let hints = defaultHints { - addrFamily = AF_INET - , addrFlags = [AI_PASSIVE] - , addrSocketType = Stream - } - addrInfo <- getAddrInfo (Just hints) Nothing $ Just $ show port - bind sock $ addrAddress $ head addrInfo - listen sock 1024 - mvar <- MVar.newEmptyMVar - MVar.putMVar mvar Map.empty - clientlist <- MVar.newEmptyMVar - MVar.putMVar clientlist [] - forkIO $ acceptClients connectionhandler mvar clientlist sock $ show port - return (mvar, clientlist) - where - acceptClients :: ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> Socket -> String -> IO () - acceptClients connectionhandler mvar clientlist socket ownport = do +waitForConversation :: ActiveConnectionsStateless -> String -> String -> Int -> Int -> IO (Maybe Handle) +waitForConversation ac hostname port waitTime tries = do + mbyHandle <- startConversation ac hostname port waitTime tries + case mbyHandle of + Just handle -> return mbyHandle + Nothing -> waitForConversation ac hostname port waitTime tries + + +acceptConversations :: ActiveConnectionsStateless -> ConnectionHandler -> Int -> MVar.MVar (Map.Map Int ServerSocket) -> IO ServerSocket +acceptConversations ac connectionhandler port socketsmvar = do + sockets <- MVar.takeMVar socketsmvar + case Map.lookup port sockets of + Just socket -> do + MVar.putMVar socketsmvar sockets + return socket + Nothing -> do + Config.traceIO "Creating socket!" + (mvar, clientlist) <- createServer ac connectionhandler port + Config.traceIO "Socket created" + let newsocket = (mvar, clientlist, show port) + let updatedMap = Map.insert port newsocket sockets + MVar.putMVar socketsmvar updatedMap + return newsocket + where + createServer :: ActiveConnectionsStateless -> ConnectionHandler -> Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), MVar.MVar [(String, Syntax.Type)]) + createServer activeCons connectionhandler port = do + -- serverid <- UserID.newRandomUserID + sock <- socket AF_INET Stream 0 + setSocketOption sock ReuseAddr 1 + let hints = defaultHints { + addrFamily = AF_INET + , addrFlags = [AI_PASSIVE] + , addrSocketType = Stream + } + addrInfo <- getAddrInfo (Just hints) Nothing $ Just $ show port + bind sock $ addrAddress $ head addrInfo + listen sock 1024 + mvar <- MVar.newEmptyMVar + MVar.putMVar mvar Map.empty + clientlist <- MVar.newEmptyMVar + MVar.putMVar clientlist [] + forkIO $ acceptClients activeCons connectionhandler mvar clientlist sock $ show port + return (mvar, clientlist) + acceptClients :: ActiveConnectionsStateless -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> Socket -> String -> IO () + acceptClients activeCons connectionhandler mvar clientlist socket ownport = do Config.traceIO "Waiting for clients" clientsocket <- accept socket Config.traceIO "Accepted new client" - forkIO $ acceptClient connectionhandler mvar clientlist clientsocket ownport - acceptClients connectionhandler mvar clientlist socket ownport + forkIO $ acceptClient activeCons connectionhandler mvar clientlist clientsocket ownport + acceptClients activeCons connectionhandler mvar clientlist socket ownport - acceptClient :: ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> String -> IO () - acceptClient connectionhandler mvar clientlist clientsocket ownport = do + acceptClient :: ActiveConnectionsStateless -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> String -> IO () + acceptClient activeCons connectionhandler mvar clientlist clientsocket ownport = do hdl <- getSocketFromHandle $ fst clientsocket - recieveMessage hdl VG.parseMessages (\_ -> return ()) $ connectionhandler mvar clientlist clientsocket hdl ownport + recieveMessageInternal hdl VG.parseMessages (\_ -> return ()) $ connectionhandler activeCons mvar clientlist clientsocket hdl ownport hClose hdl @@ -114,19 +137,22 @@ getFromNetworkThreadWithModification func threadid mvar waitTime currentTry = do recieveResponse :: Handle -> Int -> Int -> IO (Maybe Responses) recieveResponse handle waitTime tries = do retVal <- MVar.newEmptyMVar - threadid <- forkIO $ recieveMessage handle VG.parseResponses (\_ -> MVar.putMVar retVal Nothing) (\_ des -> MVar.putMVar retVal $ Just des) + threadid <- forkIO $ recieveMessageInternal handle VG.parseResponses (\_ -> MVar.putMVar retVal Nothing) (\_ des -> MVar.putMVar retVal $ Just des) getFromNetworkThreadWithModification id threadid retVal waitTime tries recieveNewMessage :: Handle -> IO (Handle, String, Messages) recieveNewMessage handle = do - recieveMessage handle VG.parseMessages (\_ -> recieveNewMessage handle) $ \s des -> return (handle, s, des) + recieveMessageInternal handle VG.parseMessages (\_ -> recieveNewMessage handle) $ \s des -> return (handle, s, des) endConversation :: Handle -> Int -> Int -> IO () endConversation handle waitTime tries = do - finished <- MVar.newEmptyMVar - threadid <- forkIO $ hClose handle >> MVar.putMVar finished True - _ <- getFromNetworkThread threadid finished waitTime tries + forkIO (do + finished <- MVar.newEmptyMVar + threadid <- forkIO $ hClose handle >> MVar.putMVar finished True + _ <- getFromNetworkThread threadid finished waitTime tries + return () + ) return () createActiveConnections :: IO ActiveConnectionsStateless diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 6113c76..e77f847 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -32,48 +32,13 @@ import qualified Control.Concurrent as MVar import qualified Networking.Client as NC import Control.Monad -createServer :: Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), MVar.MVar [(String, Syntax.Type)]) -createServer port = do - serverid <- UserID.newRandomUserID - sock <- socket AF_INET Stream 0 - setSocketOption sock ReuseAddr 1 - let hints = defaultHints { - addrFamily = AF_INET - , addrFlags = [AI_PASSIVE] - , addrSocketType = Stream - } - addrInfo <- getAddrInfo (Just hints) Nothing $ Just $ show port - bind sock $ addrAddress $ head addrInfo - listen sock 1024 - mvar <- MVar.newEmptyMVar - MVar.putMVar mvar Map.empty - clientlist <- MVar.newEmptyMVar - MVar.putMVar clientlist [] - forkIO $ acceptClients mvar clientlist sock $ show port - return (mvar, clientlist) +-- import qualified Networking.NetworkingMethod.Stateless as NetMethod +import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC +-- import Networking.NetworkingMethod.Stateless (acceptConversations) +-- import qualified Networking.NetworkingMethod.Fast as NetMethod -acceptClients :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> Socket -> String -> IO () -acceptClients mvar clientlist socket ownport = do - Config.traceIO "Waiting for clients" - clientsocket <- accept socket - Config.traceIO "Accepted new client" - - forkIO $ acceptClient mvar clientlist clientsocket ownport - acceptClients mvar clientlist socket ownport - --- In the nothing case we shoud wait a few seconds for other messages to resolve the issue -acceptClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> String -> IO () -acceptClient mvar clientlist clientsocket ownport = do - hdl <- NC.getHandle $ fst clientsocket - -- NC.recieveMessage hdl VG.parseMessages (\_ -> hClose hdl) (\msg des -> void $ forkIO ( do - -- handleClient mvar clientlist clientsocket hdl ownport msg des - -- hClose hdl - -- )) - NC.recieveMessage hdl VG.parseMessages (\_ -> return ()) $ handleClient mvar clientlist clientsocket hdl ownport - hClose hdl - -handleClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Messages -> IO () -handleClient mvar clientlist clientsocket hdl ownport message deserialmessages = do +handleClient :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Messages -> IO () +handleClient activeCons mvar clientlist clientsocket hdl ownport message deserialmessages = do let userid = getUserID deserialmessages -- Config.traceNetIO $ show ownport ++ " Entering redirect handler for message: "++ message netcon <- MVar.takeMVar mvar @@ -89,22 +54,22 @@ handleClient mvar clientlist clientsocket hdl ownport message deserialmessages = if redirectRequest then sendRedirect hdl netcon userid else do case deserialmessages of NewValue userid count val -> do - handleNewValue mvar userid count val ownport hdl + handleNewValue activeCons mvar userid count val ownport hdl IntroduceClient userid clientport syntype-> do handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype -- Okay message is handled in handle introduce ChangePartnerAddress userid hostname port -> do - handleChangePartnerAddress mvar userid hostname port ownport - NC.sendMessage Messages.Okay hdl + handleChangePartnerAddress activeCons mvar userid hostname port ownport + NC.sendResponse hdl Messages.Okay RequestSync userid -> do handleRequestSync mvar userid hdl - -- NC.sendMessage Messages.Okay hdl + -- NC.sendResponse Messages.Okay hdl SyncIncoming userid values -> do handleSyncIncoming mvar userid values - NC.sendMessage Messages.Okay hdl + NC.sendResponse hdl Messages.Okay RequestClose userid -> do handleRequestClose mvar userid - NC.sendMessage Messages.Okay hdl + NC.sendResponse hdl Messages.Okay IntroduceNewPartnerAddress userid port -> do networkconnectionmap <- MVar.takeMVar mvar Config.traceNetIO $ "Took MVar for message: " ++ message @@ -120,12 +85,12 @@ handleClient mvar clientlist clientsocket hdl ownport message deserialmessages = -- For some reason constate doesn't seem to properly apply MVar.putMVar mvar networkconnectionmap Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that - NC.sendMessage Messages.Okay hdl + NC.sendResponse hdl Messages.Okay _ -> do serial <- NSerialize.serialize deserialmessages Config.traceIO $ "Error unsupported networkmessage: "++ serial - NC.sendMessage Messages.Okay hdl + NC.sendResponse hdl Messages.Okay Nothing -> do Config.traceNetIO "Recieved message from unknown connection!" if redirectRequest then sendRedirect hdl netcon userid else do @@ -134,14 +99,14 @@ handleClient mvar clientlist clientsocket hdl ownport message deserialmessages = handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype -- Okay message is handled in handle introduce IntroduceNewPartnerAddress userid port -> do - -- NC.sendMessage Messages.Okay hdl - NC.sendMessage Messages.Wait hdl + -- NC.sendResponse Messages.Okay hdl + NC.sendResponse hdl Messages.Wait -- We don't know them yet, but should know them as soon as we get the message from the former comm partner _ -> do serial <- NSerialize.serialize deserialmessages Config.traceIO $ "Error unsupported networkmessage: "++ serial Config.traceIO "This is probably a timing issue! Lets resend later" - NC.sendMessage Messages.Wait hdl + NC.sendResponse hdl Messages.Wait Config.traceNetIO $ " Message: " ++ message @@ -166,11 +131,11 @@ sendRedirect handle ncmap userid = do case constate of RedirectRequest _ _ host port -> do Config.traceNetIO $ "Send redirect to:" ++ host ++ ":" ++ port - NC.sendMessage (Messages.Redirect host port) handle + NC.sendResponse handle (Messages.Redirect host port) _ -> return () -handleNewValue :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> Int -> Value -> String -> Handle -> IO () -handleNewValue mvar userid count val ownport hdl = do +handleNewValue :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> Int -> Value -> String -> Handle -> IO () +handleNewValue activeCons mvar userid count val ownport hdl = do -- networkconnectionmap <- MVar.takeMVar mvar networkconnectionmap <- MVar.readMVar mvar -- Config.traceNetIO $ show ownport ++ " Entered NewValue handler" @@ -179,64 +144,62 @@ handleNewValue mvar userid count val ownport hdl = do -- Config.traceNetIO $ show ownport ++ " Reading message" success <- ND.writeMessageIfNext (ncRead networkconnection) count val -- if success then Config.traceNetIO $ show ownport ++ " Message valid" else Config.traceNetIO $ show ownport ++ " Message invalid" - unless success $ NC.sendNetworkMessage networkconnection (Messages.RequestSync $ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) (-1) + unless success $ NC.sendNetworkMessage activeCons networkconnection (Messages.RequestSync $ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) (-1) -- Config.traceNetIO $ show ownport ++ " Contacting peers" - contactNewPeers val ownport + contactNewPeers activeCons val ownport -- Config.traceNetIO $ show ownport ++ " Contacted peers" - NC.sendMessage Messages.Okay hdl + NC.sendResponse hdl Messages.Okay Nothing -> do - NC.sendMessage Messages.Okay hdl + NC.sendResponse hdl Messages.Okay Config.traceNetIO "Error during recieving a networkmessage: Introduction is needed prior to sending values!" -- Config.traceNetIO $ show ownport ++ " Leaving NewValue handler" -- MVar.putMVar mvar networkconnectionmap -contactNewPeers :: Value -> String -> IO () -contactNewPeers input ownport = case input of +contactNewPeers :: NMC.ActiveConnections -> Value -> String -> IO () +contactNewPeers activeCons input ownport = case input of VSend v -> do - nv <- contactNewPeers v ownport + nv <- contactNewPeers activeCons v ownport -- return $ VSend nv return () VPair v1 v2 -> do - nv1 <- contactNewPeers v1 ownport - nv2 <- contactNewPeers v2 ownport + nv1 <- contactNewPeers activeCons v1 ownport + nv2 <- contactNewPeers activeCons v2 ownport -- return $ VPair nv1 nv2 return () VFunc penv a b -> do - newpenv <- contactNewPeersPEnv penv ownport + newpenv <- contactNewPeersPEnv activeCons penv ownport -- return $ VFunc newpenv a b return () VDynCast v g -> do - nv <- contactNewPeers v ownport + nv <- contactNewPeers activeCons v ownport -- return $ VDynCast nv g return () VFuncCast v a b -> do - nv <- contactNewPeers v ownport + nv <- contactNewPeers activeCons v ownport -- return $ VFuncCast nv a b return () VRec penv a b c d -> do - newpenv <- contactNewPeersPEnv penv ownport + newpenv <- contactNewPeersPEnv activeCons penv ownport -- return $ VRec newpenv a b c d return () VNewNatRec penv a b c d e f g -> do - newpenv <- contactNewPeersPEnv penv ownport + newpenv <- contactNewPeersPEnv activeCons penv ownport -- return $ VNewNatRec newpenv a b c d e f g return () VChanSerial r w p o c -> do let (hostname, port) = c tempNC <- newNetworkConnection p o hostname port - NClient.sendNetworkMessage tempNC (Messages.IntroduceNewPartnerAddress o ownport) 5 + NClient.sendNetworkMessage activeCons tempNC (Messages.IntroduceNewPartnerAddress o ownport) 5 _ -> return () -- return input where - contactNewPeersPEnv :: [(String, Value)] -> String -> IO () -- [(String, Value)] - contactNewPeersPEnv [] _ = return () --return [] - contactNewPeersPEnv (x:xs) ownport = do - newval <- contactNewPeers (snd x) ownport - rest <- contactNewPeersPEnv xs ownport + contactNewPeersPEnv :: NMC.ActiveConnections -> [(String, Value)] -> String -> IO () -- [(String, Value)] + contactNewPeersPEnv _ [] _ = return () --return [] + contactNewPeersPEnv activeCons (x:xs) ownport = do + newval <- contactNewPeers activeCons (snd x) ownport + rest <- contactNewPeersPEnv activeCons xs ownport -- return $ (fst x, newval):rest return () - - handleIntroduceClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Syntax.Type -> IO () handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype = do networkconnectionmap <- MVar.takeMVar mvar @@ -250,8 +213,8 @@ handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype networkconnection <- newNetworkConnection userid serverid (hostaddressTypeToString hostname) clientport let newnetworkconnectionmap = Map.insert userid networkconnection networkconnectionmap MVar.putMVar mvar newnetworkconnectionmap - -- NC.sendMessage (Introduce serverid) hdl -- Answer with own serverid - NC.sendMessage (Messages.OkayIntroduce serverid) hdl + -- NC.sendResponse (Introduce serverid) hdl -- Answer with own serverid + NC.sendResponse hdl (Messages.OkayIntroduce serverid) repserial <- NSerialize.serialize $ Messages.OkayIntroduce serverid Config.traceNetIO $ " Response to "++ userid ++ ": " ++ repserial -- Adds the new user to the users that can be accepted by the server @@ -261,17 +224,17 @@ handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype _ -> do Config.traceIO "Error during recieving a networkmessage: only ipv4 is currently supported!" MVar.putMVar mvar networkconnectionmap - NC.sendMessage Messages.Okay hdl + NC.sendResponse hdl Messages.Okay -handleChangePartnerAddress :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> String -> IO () -handleChangePartnerAddress mvar userid hostname port ownport = do +handleChangePartnerAddress :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> String -> IO () +handleChangePartnerAddress activeCons mvar userid hostname port ownport = do networkconnectionmap <- MVar.takeMVar mvar case Map.lookup userid networkconnectionmap of Just networkconnection -> do -- Change to current network address NCon.changePartnerAddress networkconnection hostname port -- For some reason constate doesn't seem to properly apply - NClient.sendNetworkMessage networkconnection (Messages.IntroduceNewPartnerAddress (Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) ownport) 5 + NClient.sendNetworkMessage activeCons networkconnection (Messages.IntroduceNewPartnerAddress (Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) ownport) 5 MVar.putMVar mvar networkconnectionmap Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that @@ -282,7 +245,7 @@ handleRequestSync mvar userid hdl = do case Map.lookup userid networkconnectionmap of Just networkconnection -> do -- Change to current network address writevals <- ND.allMessages $ ncWrite networkconnection - NC.sendMessage (Messages.OkaySync writevals) hdl + NC.sendResponse hdl (Messages.OkaySync writevals) -- NClient.sendNetworkMessage networkconnection (SyncIncoming (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) writevals) 5 othing -> return () @@ -333,59 +296,47 @@ findFittingClient clientlist desiredType = do threadDelay 10000 -- Sleep for 10 ms to not hammer the CPU findFittingClient clientlist desiredType -replaceVChanSerial :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> Value -> IO Value -replaceVChanSerial mvar input = case input of +replaceVChanSerial :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> Value -> IO Value +replaceVChanSerial activeCons mvar input = case input of VSend v -> do - nv <- replaceVChanSerial mvar v + nv <- replaceVChanSerial activeCons mvar v return $ VSend nv VPair v1 v2 -> do - nv1 <- replaceVChanSerial mvar v1 - nv2 <- replaceVChanSerial mvar v2 + nv1 <- replaceVChanSerial activeCons mvar v1 + nv2 <- replaceVChanSerial activeCons mvar v2 return $ VPair nv1 nv2 VFunc penv a b -> do - newpenv <- replaceVChanSerialPEnv mvar penv + newpenv <- replaceVChanSerialPEnv activeCons mvar penv return $ VFunc newpenv a b VDynCast v g -> do - nv <- replaceVChanSerial mvar v + nv <- replaceVChanSerial activeCons mvar v return $ VDynCast nv g VFuncCast v a b -> do - nv <- replaceVChanSerial mvar v + nv <- replaceVChanSerial activeCons mvar v return $ VFuncCast nv a b VRec penv a b c d -> do - newpenv <- replaceVChanSerialPEnv mvar penv + newpenv <- replaceVChanSerialPEnv activeCons mvar penv return $ VRec newpenv a b c d VNewNatRec penv a b c d e f g -> do - newpenv <- replaceVChanSerialPEnv mvar penv + newpenv <- replaceVChanSerialPEnv activeCons mvar penv return $ VNewNatRec newpenv a b c d e f g VChanSerial r w p o c -> do networkconnection <- createNetworkConnectionS r w p o c ncmap <- MVar.takeMVar mvar MVar.putMVar mvar $ Map.insert p networkconnection ncmap - NClient.sendNetworkMessage networkconnection (RequestSync o) 5 + NClient.sendNetworkMessage activeCons networkconnection (RequestSync o) 5 used<- MVar.newEmptyMVar MVar.putMVar used False return $ VChan networkconnection mvar used _ -> return input where - replaceVChanSerialPEnv :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> [(String, Value)] -> IO [(String, Value)] - replaceVChanSerialPEnv mvar [] = return [] - replaceVChanSerialPEnv mvar (x:xs) = do - newval <- replaceVChanSerial mvar $ snd x - rest <- replaceVChanSerialPEnv mvar xs + replaceVChanSerialPEnv :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> [(String, Value)] -> IO [(String, Value)] + replaceVChanSerialPEnv _ _ [] = return [] + replaceVChanSerialPEnv activeCons mvar (x:xs) = do + newval <- replaceVChanSerial activeCons mvar $ snd x + rest <- replaceVChanSerialPEnv activeCons mvar xs return $ (fst x, newval):rest -ensureSocket :: Int -> MVar.MVar (Map.Map Int ServerSocket) -> IO ServerSocket -ensureSocket port socketsmvar = do - sockets <- MVar.takeMVar socketsmvar - case Map.lookup port sockets of - Just socket -> do - MVar.putMVar socketsmvar sockets - return socket - Nothing -> do - Config.traceIO "Creating socket!" - (mvar, clientlist) <- createServer port - Config.traceIO "Socket created" - let newsocket = (mvar, clientlist, show port) - let updatedMap = Map.insert port newsocket sockets - MVar.putMVar socketsmvar updatedMap - return newsocket \ No newline at end of file +-- createActiveConnections = NetMethod.createActiveConnections + +-- acceptConversations = NetMethod.acceptConversations From a513be88fb0a44a4e3c0840a9d7e3fa7c797c1fc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 30 Jan 2023 17:31:25 +0100 Subject: [PATCH 089/229] Slightly more stable now --- ldgv.cabal | 5 +-- package.yaml | 1 + src/Interpreter.hs | 2 +- src/Networking/Client.hs | 2 +- src/Networking/DirectionalConnection.hs | 34 ++++++++++++++++---- src/Networking/NetworkingMethod/Stateless.hs | 11 +++---- src/Networking/Server.hs | 6 ++++ 7 files changed, 43 insertions(+), 18 deletions(-) diff --git a/ldgv.cabal b/ldgv.cabal index c8f5884..5d4f358 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.34.6. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack @@ -100,7 +100,8 @@ library alex , happy build-depends: - array + SafeSemaphore >=0.10.1 + , array , base >=4.12 && <5 , bytestring , containers diff --git a/package.yaml b/package.yaml index e74a555..5fb8c78 100644 --- a/package.yaml +++ b/package.yaml @@ -63,6 +63,7 @@ library: - network - network-run - random + - SafeSemaphore >=0.10.1 tests: ldgv-test: diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 2be4284..97a1a36 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -202,7 +202,7 @@ eval = \case used <- liftIO $ MVar.readMVar usedmvar if used then throw $ VChanIsUsedException $ show v else do let dcRead = NCon.ncRead ci - valunclean <- liftIO $ DC.readUnreadMessage dcRead + valunclean <- liftIO $ DC.readUnreadMessageInterpreter dcRead (env, (sockets, activeConnections)) <- ask val <- liftIO $ NS.replaceVChanSerial activeConnections mvar valunclean liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index fa1fc4c..f482a71 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -143,7 +143,7 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen when (Data.Maybe.isNothing mbycon) $ Config.traceNetIO "Not connected to peer" Config.traceNetIO $ "Original message: " ++ serializedMessage case connectionstate of - NCon.Connected newhostname newport -> if resendOnError /= 0 then do + NCon.Connected newhostname newport -> if resendOnError /= 0 && Data.Maybe.isJust mbycon then do Config.traceNetIO $ "Old communication partner offline! New communication partner: " ++ newhostname ++ ":" ++ newport threadDelay 1000000 tryToSendNetworkMessage activeCons networkconnection newhostname newport message $ max (resendOnError-1) (-1) diff --git a/src/Networking/DirectionalConnection.hs b/src/Networking/DirectionalConnection.hs index 86de0fe..4b0ed7b 100644 --- a/src/Networking/DirectionalConnection.hs +++ b/src/Networking/DirectionalConnection.hs @@ -1,8 +1,10 @@ -module Networking.DirectionalConnection (DirectionalConnection(..), newConnection, createConnection, writeMessage, writeMessageIfNext, countMessages, allMessages, readUnreadMessage, readUnreadMessageMaybe, serializeConnection, syncMessages) where +module Networking.DirectionalConnection where import Control.Concurrent.MVar +import Control.Concurrent +import qualified Control.Concurrent.SSem as SSem -data DirectionalConnection a = DirectionalConnection { messages :: MVar [a], messagesUnreadStart :: MVar Int, messagesCount :: MVar Int} +data DirectionalConnection a = DirectionalConnection { messages :: MVar [a], messagesUnreadStart :: MVar Int, messagesCount :: MVar Int, readLock :: SSem.SSem} deriving Eq -- When a channel is duplicated there are no unread messages in the new channel, only the old one @@ -15,7 +17,8 @@ newConnection = do putMVar messagesUnreadStart 0 messagesCount <- newEmptyMVar putMVar messagesCount 0 - return $ DirectionalConnection messages messagesUnreadStart messagesCount + readLock <- SSem.new 1 + return $ DirectionalConnection messages messagesUnreadStart messagesCount readLock createConnection :: [a] -> Int -> IO (DirectionalConnection a) @@ -26,7 +29,8 @@ createConnection messages unreadStart = do putMVar messagesUnreadStart unreadStart messagesCount <- newEmptyMVar putMVar messagesCount $ length messages - return $ DirectionalConnection msg messagesUnreadStart messagesCount + readLock <- SSem.new 1 + return $ DirectionalConnection msg messagesUnreadStart messagesCount readLock writeMessage :: DirectionalConnection a -> a -> IO () @@ -58,18 +62,28 @@ allMessages :: DirectionalConnection a -> IO [a] allMessages connection = readMVar (messages connection) readUnreadMessageMaybe :: DirectionalConnection a -> IO (Maybe a) -readUnreadMessageMaybe connection = modifyMVar (messagesUnreadStart connection) (\i -> do +readUnreadMessageMaybe connection = modifyMVar (messagesUnreadStart connection) (\i -> do messagesBind <- allMessages connection if length messagesBind == i then return (i, Nothing) else return ((i+1), Just (messagesBind!!i)) ) readUnreadMessage :: DirectionalConnection a -> IO a -readUnreadMessage connection = do +readUnreadMessage connection = do maybeval <- readUnreadMessageMaybe connection case maybeval of - Nothing -> readUnreadMessage connection + Nothing -> do + threadDelay 1000 + readUnreadMessage connection Just val -> return val +readUnreadMessageInterpreter :: DirectionalConnection a -> IO a +readUnreadMessageInterpreter connection = do + maybeval <- SSem.withSem (readLock connection) $ readUnreadMessageMaybe connection + case maybeval of + Nothing -> do + threadDelay 1000 + readUnreadMessage connection + Just val -> return val serializeConnection :: DirectionalConnection a -> IO ([a], Int) serializeConnection connection = do @@ -80,6 +94,12 @@ serializeConnection connection = do countMessages :: DirectionalConnection a -> IO Int countMessages connection = readMVar $ messagesCount connection +lockInterpreterReads :: DirectionalConnection a -> IO () +lockInterpreterReads connection = SSem.wait (readLock connection) + +unlockInterpreterReads :: DirectionalConnection a -> IO () +unlockInterpreterReads connection = SSem.signal (readLock connection) + test = do mycon <- newConnection writeMessage mycon "a" diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index 1a0337f..56463a0 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -35,7 +35,7 @@ recieveMessageInternal handle grammar fallbackResponse messageHandler = do message <- hGetLine handle case VT.runAlex message grammar of Left err -> do - Config.traceNetIO $ "Error during recieving a networkmessage: "++err + Config.traceNetIO $ "Error during recieving a networkmessage: "++err++" Malformed message: " ++ message fallbackResponse message Right deserialmessage -> do -- Config.traceNetIO $ "New superficially valid message recieved: "++message @@ -147,12 +147,9 @@ recieveNewMessage handle = do endConversation :: Handle -> Int -> Int -> IO () endConversation handle waitTime tries = do - forkIO (do - finished <- MVar.newEmptyMVar - threadid <- forkIO $ hClose handle >> MVar.putMVar finished True - _ <- getFromNetworkThread threadid finished waitTime tries - return () - ) + finished <- MVar.newEmptyMVar + threadid <- forkIO $ hClose handle >> MVar.putMVar finished True + _ <- getFromNetworkThread threadid finished waitTime tries return () createActiveConnections :: IO ActiveConnectionsStateless diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index e77f847..33a3c54 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -98,10 +98,12 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria IntroduceClient userid clientport syntype-> do handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype -- Okay message is handled in handle introduce + {- IntroduceNewPartnerAddress userid port -> do -- NC.sendResponse Messages.Okay hdl NC.sendResponse hdl Messages.Wait -- We don't know them yet, but should know them as soon as we get the message from the former comm partner + -} _ -> do serial <- NSerialize.serialize deserialmessages Config.traceIO $ "Error unsupported networkmessage: "++ serial @@ -141,6 +143,8 @@ handleNewValue activeCons mvar userid count val ownport hdl = do -- Config.traceNetIO $ show ownport ++ " Entered NewValue handler" case Map.lookup userid networkconnectionmap of Just networkconnection -> do + ND.lockInterpreterReads (ncRead networkconnection) + -- Config.traceNetIO "ENTERED READ LOCK" -- Config.traceNetIO $ show ownport ++ " Reading message" success <- ND.writeMessageIfNext (ncRead networkconnection) count val -- if success then Config.traceNetIO $ show ownport ++ " Message valid" else Config.traceNetIO $ show ownport ++ " Message invalid" @@ -149,6 +153,8 @@ handleNewValue activeCons mvar userid count val ownport hdl = do contactNewPeers activeCons val ownport -- Config.traceNetIO $ show ownport ++ " Contacted peers" NC.sendResponse hdl Messages.Okay + ND.unlockInterpreterReads (ncRead networkconnection) + -- Config.traceNetIO "LEFT READ LOCK" Nothing -> do NC.sendResponse hdl Messages.Okay Config.traceNetIO "Error during recieving a networkmessage: Introduction is needed prior to sending values!" From c975de5999221d7a4090f07073ff834f19116643 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 30 Jan 2023 18:32:50 +0100 Subject: [PATCH 090/229] Added new tests - Bidirhandoff seems stable --- testNWCount.sh | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/testNWCount.sh b/testNWCount.sh index db51a88..762cda4 100644 --- a/testNWCount.sh +++ b/testNWCount.sh @@ -3,6 +3,8 @@ for i in {1..1000}; do clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/simple/server.ldgvnw & stack run ldgv -- interpret < dev-examples/simple/client.ldgvnw & wait); clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirectional/client.ldgvnw & wait); clear; echo "$i Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff/client.ldgvnw & wait); - clear; echo "$i Handoff2"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/client.ldgvnw & wait); + clear; echo "$i Handoff2"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/client.ldgvnw & wait); + clear; echo "$i Handoff3"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff3/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/client.ldgvnw & wait); + clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/client.ldgvnw & wait); clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/client.ldgvnw & wait); done \ No newline at end of file From fd41f76f7d3baed8665de37551c224e5909aa639 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 30 Jan 2023 20:12:49 +0100 Subject: [PATCH 091/229] First test with new fast implementation --- src/Networking/Client.hs | 7 +- src/Networking/Common.hs | 5 +- src/Networking/NetworkingMethod/Fast.hs | 135 ++++++++++++------ .../NetworkingMethodCommon.hs | 11 +- src/Networking/Server.hs | 10 +- 5 files changed, 112 insertions(+), 56 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index f482a71..a3758ea 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -180,14 +180,17 @@ initialConnect activeCons mvar hostname port ownport syntype= do case mbycon of Just con -> do ownuserid <- UserID.newRandomUserID - Config.traceIO "Client connected: Introducing" + Config.traceNetIO "Client connected: Introducing" NC.sendMessage con (Messages.IntroduceClient ownuserid ownport syntype) + Config.traceNetIO "Client connected: send message" mbyintroductionanswer <- NC.recieveResponse con 10000 (-1) + Config.traceNetIO "Client connected: got answer" NC.endConversation con 10000 10 + Config.traceNetIO "Client disconnected!" case mbyintroductionanswer of Just introduction -> case introduction of OkayIntroduce introductionanswer -> do - Config.traceIO "Finished Handshake" + Config.traceNetIO "Finished Handshake" msgserial <- NSerialize.serialize $ Messages.IntroduceClient ownuserid ownport syntype Config.traceNetIO $ "Sending message as: " ++ ownuserid ++ " to: " ++ introductionanswer Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index b3c93a4..590f3c6 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -9,9 +9,12 @@ import qualified Networking.Serialize as NSerialize import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG import qualified Config -import qualified Networking.NetworkingMethod.Stateless as NetMethod +import qualified Networking.NetworkingMethod.Fast as NetMethod +type ConversationOrHandle = NetMethod.Conversation + +-- type ConversationOrHandle = Handle -- The compiler sadly compains when these things get eta reduced :/ sendMessage con ser = NetMethod.sendMessage con ser diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index f25943c..a422caf 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -21,8 +21,11 @@ import qualified ValueParsing.ValueGrammar as VG import qualified Config import qualified Networking.NetworkingMethod.Stateless as Stateless import ProcessEnvironmentTypes +import qualified Control.Concurrent.SSem as SSem -type Conversation = (String, Handle, MVar.MVar (Map.Map String (String, Responses))) +type Conversation = (String, Handle, MVar.MVar (Map.Map String (String, Responses)), SSem.SSem) + +type ConnectionHandler = ActiveConnectionsFast -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Conversation -> String -> String -> Messages -> IO () -- type NetworkAddress = (String, String) -- deriving (Eq, Show, Ord) @@ -31,39 +34,53 @@ type Conversation = (String, Handle, MVar.MVar (Map.Map String (String, Response sendMessage :: Conversation -> Messages -> IO () -sendMessage conversation@(cid, handle, responses) value = Stateless.sendMessage handle (ConversationMessage cid value) +sendMessage conversation@(cid, handle, responses, sem) value = SSem.withSem sem $ Stateless.sendMessage handle (ConversationMessage cid value) sendResponse :: Conversation -> Responses -> IO () -sendResponse conversation@(cid, handle, responses) value = Stateless.sendResponse handle (ConversationResponse cid value) +sendResponse conversation@(cid, handle, responses, sem) value = SSem.withSem sem $ Stateless.sendResponse handle (ConversationResponse cid value) conversationHandler :: Handle -> IO Connection conversationHandler handle = do chan <- Chan.newChan mvar <- MVar.newEmptyMVar - forkIO $ forever $ Stateless.recieveMessageInternal handle VG.parseConversation (\_ -> return ()) (\mes des -> case des of - ConversationMessage cid message -> Chan.writeChan chan (cid, (mes, message)) - ConversationResponse cid response -> do - mymap <- MVar.takeMVar mvar - MVar.putMVar mvar $ Map.insert cid (mes, response) mymap + MVar.putMVar mvar Map.empty + sem <- SSem.new 1 + forkIO $ forever (do + -- Config.traceNetIO "Waiting for new conversation" + Stateless.recieveMessageInternal handle VG.parseConversation (\_ -> return ()) (\mes des -> do + -- Config.traceNetIO "Got new conversation" + case des of + ConversationMessage cid message -> Chan.writeChan chan (cid, (mes, message)) + ConversationResponse cid response -> do + -- Config.traceNetIO "Trying to take mvar" + mymap <- MVar.takeMVar mvar + MVar.putMVar mvar $ Map.insert cid (mes, response) mymap + -- Config.traceNetIO "Set responses mvar" + ) ) - return (handle, chan, mvar) + return (handle, chan, mvar, sem) recieveResponse :: Conversation -> Int -> Int -> IO (Maybe Responses) -recieveResponse conversation@(cid, handle, mvar) waitTime tries = do +recieveResponse conversation@(cid, handle, mvar, sem) waitTime tries = do + -- Config.traceNetIO "Trying to take mvar for responses mvar" responsesMap <- MVar.takeMVar mvar + -- Config.traceNetIO "Got MVar for responses" case Map.lookup cid responsesMap of Just (messages, deserial) -> do MVar.putMVar mvar $ Map.delete cid responsesMap return $ Just deserial Nothing -> do MVar.putMVar mvar responsesMap - if tries /= 0 then recieveResponse conversation waitTime $ max (tries-1) (-1) else return Nothing + if tries /= 0 then do + -- Config.traceNetIO "Nothing yet retrying!" + threadDelay waitTime + recieveResponse conversation waitTime $ max (tries-1) (-1) else return Nothing recieveNewMessage :: Connection -> IO (Conversation, String, Messages) -recieveNewMessage connection@(handle, chan, mvar) = do +recieveNewMessage connection@(handle, chan, mvar, sem) = do (cid, (serial, deserial)) <- Chan.readChan chan - return ((cid, handle, mvar), serial, deserial) + return ((cid, handle, mvar, sem), serial, deserial) startConversation :: ActiveConnectionsFast -> String -> String -> Int -> Int -> IO (Maybe Conversation) @@ -71,62 +88,92 @@ startConversation acmvar hostname port waitTime tries = do conversationid <- newRandomUserID connectionMap <- MVar.takeMVar acmvar case Map.lookup (hostname, port) connectionMap of - Just (handle, chan, mvar) -> do + Just (handle, chan, mvar, sem) -> do MVar.putMVar acmvar connectionMap - return $ Just (conversationid, handle, mvar) + return $ Just (conversationid, handle, mvar, sem) Nothing -> do statelessActiveCons <- Stateless.createActiveConnections mbyNewHandle <- Stateless.startConversation statelessActiveCons hostname port waitTime tries case mbyNewHandle of Just handle -> do - newconnection@(handle, chan, mvar) <- conversationHandler handle + newconnection@(handle, chan, mvar, sem) <- conversationHandler handle MVar.putMVar acmvar $ Map.insert (hostname, port) newconnection connectionMap - return $ Just (conversationid, handle, mvar) + return $ Just (conversationid, handle, mvar, sem) Nothing -> do MVar.putMVar acmvar connectionMap return Nothing +waitForConversation :: ActiveConnectionsFast -> String -> String -> Int -> Int -> IO (Maybe Conversation) +waitForConversation ac hostname port waitTime tries = do + mbyHandle <- startConversation ac hostname port waitTime tries + case mbyHandle of + Just handle -> return mbyHandle + Nothing -> waitForConversation ac hostname port waitTime tries + createActiveConnections :: IO ActiveConnectionsFast createActiveConnections = do activeConnections <- MVar.newEmptyMVar MVar.putMVar activeConnections Map.empty return activeConnections -{- -acceptConversations :: ActiveConnectionsFast -> ConnectionHandler -> Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), MVar.MVar [(String, Syntax.Type)]) -acceptConversations ActiveConnectionsFast connectionhandler port = do - sock <- socket AF_INET Stream 0 - setSocketOption sock ReuseAddr 1 - let hints = defaultHints { - addrFamily = AF_INET - , addrFlags = [AI_PASSIVE] - , addrSocketType = Stream - } - addrInfo <- getAddrInfo (Just hints) Nothing $ Just $ show port - bind sock $ addrAddress $ head addrInfo - listen sock 1024 - mvar <- MVar.newEmptyMVar - MVar.putMVar mvar Map.empty - clientlist <- MVar.newEmptyMVar - MVar.putMVar clientlist [] - forkIO $ acceptClients connectionhandler mvar clientlist sock $ show port - return (mvar, clientlist) + +acceptConversations :: ActiveConnectionsFast -> ConnectionHandler -> Int -> MVar.MVar (Map.Map Int ServerSocket) -> IO ServerSocket +acceptConversations ac connectionhandler port socketsmvar = do + sockets <- MVar.takeMVar socketsmvar + case Map.lookup port sockets of + Just socket -> do + MVar.putMVar socketsmvar sockets + return socket + Nothing -> do + Config.traceIO "Creating socket!" + (mvar, clientlist) <- createServer ac connectionhandler port + Config.traceIO "Socket created" + let newsocket = (mvar, clientlist, show port) + let updatedMap = Map.insert port newsocket sockets + MVar.putMVar socketsmvar updatedMap + return newsocket where + createServer :: ActiveConnectionsFast -> ConnectionHandler -> Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), MVar.MVar [(String, Syntax.Type)]) + createServer activeCons connectionhandler port = do + -- serverid <- UserID.newRandomUserID + sock <- socket AF_INET Stream 0 + setSocketOption sock ReuseAddr 1 + let hints = defaultHints { + addrFamily = AF_INET + , addrFlags = [AI_PASSIVE] + , addrSocketType = Stream + } + addrInfo <- getAddrInfo (Just hints) Nothing $ Just $ show port + bind sock $ addrAddress $ head addrInfo + listen sock 1024 + mvar <- MVar.newEmptyMVar + MVar.putMVar mvar Map.empty + clientlist <- MVar.newEmptyMVar + MVar.putMVar clientlist [] + forkIO $ acceptClients activeCons connectionhandler mvar clientlist sock $ show port + return (mvar, clientlist) + acceptClients :: ActiveConnectionsFast -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> Socket -> String -> IO () - acceptClients ActiveConnectionsFast connectionhandler mvar clientlist socket ownport = do + acceptClients activeCons connectionhandler mvar clientlist socket ownport = do Config.traceIO "Waiting for clients" clientsocket <- accept socket Config.traceIO "Accepted new client" - forkIO $ acceptClient activeConections connectionhandler mvar clientlist clientsocket ownport - acceptClients ActiveConnectionsFast connectionhandler mvar clientlist socket ownport + forkIO $ acceptClient activeCons connectionhandler mvar clientlist clientsocket ownport + acceptClients activeCons connectionhandler mvar clientlist socket ownport acceptClient :: ActiveConnectionsFast -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> String -> IO () - acceptClient ActiveConnectionsFast connectionhandler mvar clientlist clientsocket ownport = do - hdl <- NC.getHandle $ fst clientsocket - NC.recieveMessage hdl VG.parseMessages (\_ -> return ()) $ connectionhandler mvar clientlist clientsocket hdl ownport - hClose hdl --} + acceptClient activeCons connectionhandler mvar clientlist clientsocket ownport = do + hdl <- Stateless.getSocketFromHandle $ fst clientsocket + connection@(handle, chan, responsesMvar, sem) <- conversationHandler hdl + -- NC.recieveMessage hdl VG.parseMessages (\_ -> return ()) $ connectionhandler mvar clientlist clientsocket hdl ownport + forkIO $ forever (do + (conversationid, (serial, deserial)) <- Chan.readChan chan + connectionhandler activeCons mvar clientlist clientsocket (conversationid, hdl, responsesMvar, sem) ownport serial deserial + ) + return () + -- hClose hdl + endConversation :: Conversation -> Int -> Int -> IO () endConversation _ _ _ = return () diff --git a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs index 55eec49..c77e1b8 100644 --- a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs +++ b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs @@ -5,13 +5,16 @@ import qualified Control.Concurrent.Chan as Chan import qualified Control.Concurrent.MVar as MVar import qualified Data.Map as Map import Networking.Messages +import qualified Control.Concurrent.SSem as SSem -type ActiveConnections = ActiveConnectionsStateless +-- type ActiveConnections = ActiveConnectionsStateless -data ActiveConnectionsStateless = ActiveConnectionsStateless +type ActiveConnections = ActiveConnectionsFast -type Connection = (Handle, Chan.Chan (String, (String, Messages)), MVar.MVar (Map.Map String (String, Responses))) +data ActiveConnectionsStateless = ActiveConnectionsStateless +type Connection = (Handle, Chan.Chan (String, (String, Messages)), MVar.MVar (Map.Map String (String, Responses)), SSem.SSem) +-- Conversationid serial deserial type ActiveConnectionsFast = MVar.MVar (Map.Map NetworkAddress Connection) -type NetworkAddress = (String, String) \ No newline at end of file +type NetworkAddress = (String, String) diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 33a3c54..527ba5f 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -37,7 +37,7 @@ import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC -- import Networking.NetworkingMethod.Stateless (acceptConversations) -- import qualified Networking.NetworkingMethod.Fast as NetMethod -handleClient :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Messages -> IO () +handleClient :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> Messages -> IO () handleClient activeCons mvar clientlist clientsocket hdl ownport message deserialmessages = do let userid = getUserID deserialmessages -- Config.traceNetIO $ show ownport ++ " Entering redirect handler for message: "++ message @@ -124,7 +124,7 @@ checkRedirectRequest ncmap userid = do RedirectRequest {} -> return True _ -> return False -sendRedirect :: Handle -> Map.Map String (NetworkConnection Value) -> String -> IO () +sendRedirect :: NC.ConversationOrHandle -> Map.Map String (NetworkConnection Value) -> String -> IO () sendRedirect handle ncmap userid = do case Map.lookup userid ncmap of Nothing -> return () @@ -136,7 +136,7 @@ sendRedirect handle ncmap userid = do NC.sendResponse handle (Messages.Redirect host port) _ -> return () -handleNewValue :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> Int -> Value -> String -> Handle -> IO () +handleNewValue :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> Int -> Value -> String -> NC.ConversationOrHandle -> IO () handleNewValue activeCons mvar userid count val ownport hdl = do -- networkconnectionmap <- MVar.takeMVar mvar networkconnectionmap <- MVar.readMVar mvar @@ -206,7 +206,7 @@ contactNewPeers activeCons input ownport = case input of -- return $ (fst x, newval):rest return () -handleIntroduceClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Syntax.Type -> IO () +handleIntroduceClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> Syntax.Type -> IO () handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype = do networkconnectionmap <- MVar.takeMVar mvar case Map.lookup userid networkconnectionmap of @@ -245,7 +245,7 @@ handleChangePartnerAddress activeCons mvar userid hostname port ownport = do Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that -handleRequestSync :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> Handle -> IO () +handleRequestSync :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> NC.ConversationOrHandle -> IO () handleRequestSync mvar userid hdl = do networkconnectionmap <- MVar.readMVar mvar case Map.lookup userid networkconnectionmap of From 55e8288eecd7b0e8f3e7a7d3c9f444ff67b9919d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 30 Jan 2023 21:15:18 +0100 Subject: [PATCH 092/229] notes for bugfix --- src/FastNetworkingBug.log | 997 ++++++++++++++++++++++++++++++++++++++ src/Interpreter.hs | 1 + 2 files changed, 998 insertions(+) create mode 100644 src/FastNetworkingBug.log diff --git a/src/FastNetworkingBug.log b/src/FastNetworkingBug.log new file mode 100644 index 0000000..81d42be --- /dev/null +++ b/src/FastNetworkingBug.log @@ -0,0 +1,997 @@ +1051 Bidirhandoff +subtype: Entering [(c, (0, SendInt))] (Nat) (Int) +subtype: Entering [ (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Nat) (Int) +subtype: Entering [ (y2, (_, ())) +, (m, (_, Int)) +, (y, (0, ?Int. ())) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Int) (Int) +subtype: Entering [(c, (0, SendInt))] (Nat) (Int) +subtype: Entering [ (y2, (_, ())) +, (m, (_, Int)) +, (y, (0, ?Int. ())) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Int) (Int) +subtype: Entering [ (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (c32, (_, ())) +, (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: Entering [ (c32, (_, ())) +, (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: Entering [ (y, (_, ())) +, (talk, (0, SendIntClient)) +, (con, (0, ~SendSendIntClient)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: Entering [ (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Nat) (Int) +subtype: Entering [ (y2, (_, ())) +, (m, (_, Int)) +, (y, (0, ?Int. ())) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Int) (Int) +subtype: Entering [(c, (0, SendInt))] (Nat) (Int) +subtype: Entering [ (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Nat) (Int) +subtype: Entering [ (y2, (_, ())) +, (m, (_, Int)) +, (y, (0, ?Int. ())) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Int) (Int) +subtype: Entering [ (y2, (_, ())) +, (m, (_, Int)) +, (y, (0, ?Int. ())) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Int) (Int) +subtype: Entering [ (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (c32, (_, ())) +, (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: Entering [ (c32, (_, ())) +, (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: Entering [ (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (con, (0, ~SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (con2, (0, SendSendIntServer)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (con, (0, ~SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (?Int. !Int. ()) (SendIntServer) +subtype: Entering [ (con2, (0, SendSendIntServer)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (con, (0, ~SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (?Int. !Int. ()) (?Int. !Int. ()) +subtype: Entering [ (con2, (0, SendSendIntServer)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (con, (0, ~SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: [ (con2, (0, SendSendIntServer)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (con, (0, ~SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) = Kunit +subtype: Entering [ (zz8, (_, Int)) +, (con2, (0, SendSendIntServer)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (con, (0, ~SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (!Int. ()) (!Int. ()) +subtype: Entering [ (zz8, (_, Int)) +, (con2, (0, SendSendIntServer)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (con, (0, ~SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: [ (zz8, (_, Int)) +, (con2, (0, SendSendIntServer)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (con, (0, ~SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) = Kunit +subtype: Entering [ (zz9, (_, Int)) +, (zz8, (_, Int)) +, (con2, (0, SendSendIntServer)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (con, (0, ~SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (()) (()) +subtype: Entering [ (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: Entering [ (y2, (_, ())) +, (m, (_, Int)) +, (y, (0, ?Int. ())) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Int) (Int) +subtype: Entering [ (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (c32, (_, ())) +, (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: Entering [ (c32, (_, ())) +, (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: Entering [ (con, (0, SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (con2, (0, SendSendIntClient)) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (con, (0, SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (!Int. ?Int. ()) (SendIntClient) +subtype: Entering [ (con2, (0, SendSendIntClient)) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (con, (0, SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (!Int. ?Int. ()) (!Int. ?Int. ()) +subtype: Entering [ (con2, (0, SendSendIntClient)) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (con, (0, SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: [ (con2, (0, SendSendIntClient)) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (con, (0, SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) = Kunit +subtype: Entering [ (zz8, (_, Int)) +, (con2, (0, SendSendIntClient)) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (con, (0, SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (?Int. ()) (?Int. ()) +subtype: Entering [ (zz8, (_, Int)) +, (con2, (0, SendSendIntClient)) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (con, (0, SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: [ (zz8, (_, Int)) +, (con2, (0, SendSendIntClient)) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (con, (0, SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) = Kunit +subtype: Entering [ (zz9, (_, Int)) +, (zz8, (_, Int)) +, (con2, (0, SendSendIntClient)) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (con, (0, SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (()) (()) +subtype: Entering [ (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +Trying to connect to: 127.0.0.1:4242 +subtype: Entering [(c, (0, SendInt))] (Nat) (Int) +subtype: Entering [ (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Nat) (Int) +subtype: Entering [ (y2, (_, ())) +, (m, (_, Int)) +, (y, (0, ?Int. ())) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Int) (Int) +Client connected: Introducing +Client connected: send message +Recieved message from unknown connection! + Response to nSmP4vJF: NOkayIntroduce (String:"y0loScB1") + Message: NConversationMessage (String:"KgNtutI8") (NIntroduceClient (String:"nSmP4vJF") (String:"4343") (TName (Bool:False) (String:"SendInt"))) +subtype: Entering [ (y2, (_, ())) +, (m, (_, Int)) +, (y, (0, ?Int. ())) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Int) (Int) +subtype: Entering [ (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (c32, (_, ())) +, (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: Entering [ (c32, (_, ())) +, (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: Entering [ (c2, (0, !Int. ())) +, (m, (_, Int)) +, (c1, (_, ())) +, (talk, (0, SendIntServer)) +, (con, (0, ~SendSendIntServer)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +Trying to connect to: 127.0.0.1:4242 +Client connected: got answer +Client disconnected! +Finished Handshake +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceClient (String:"nSmP4vJF") (String:"4343") (TName (Bool:False) (String:"SendInt")) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NNewValue (String:"nSmP4vJF") (Int:1) (VInt (Int:1)) +Client connected: Introducing +Client connected: send message +Recieved message from unknown connection! + Response to 9o1aHTcp: NOkayIntroduce (String:"FxLP6Xqs") + Message: NConversationMessage (String:"JlhXySIQ") (NIntroduceClient (String:"9o1aHTcp") (String:"4240") (TName (Bool:True) (String:"SendSendIntServer"))) +Client connected: got answer +Client disconnected! +Finished Handshake +Sending message as: 9o1aHTcp to: FxLP6Xqs + Over: 127.0.0.1:4242 + Message: NIntroduceClient (String:"9o1aHTcp") (String:"4240") (TName (Bool:True) (String:"SendSendIntServer")) +Recieved message as: y0loScB1 (4242) from: nSmP4vJF + Message: NConversationMessage (String:"6d2mTsHp") (NNewValue (String:"nSmP4vJF") (Int:1) (VInt (Int:1))) +Sending message as: y0loScB1 to: nSmP4vJF + Over: 127.0.0.1:4343 + Message: NNewValue (String:"y0loScB1") (Int:1) (VInt (Int:1300)) +Trying to connect to: 127.0.0.1:4343 +Recieved message as: nSmP4vJF (4343) from: y0loScB1 + Message: NConversationMessage (String:"OdtXfcAm") (NNewValue (String:"y0loScB1") (Int:1) (VInt (Int:1300))) +Message okay: NNewValue (String:"y0loScB1") (Int:1) (VInt (Int:1300)) +Set RedirectRequest for nSmP4vJF to 127.0.0.1:4240 +Sending message as: FxLP6Xqs to: 9o1aHTcp + Over: 127.0.0.1:4240 + Message: NNewValue (String:"FxLP6Xqs") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray [VInt (Int:1300)]) (Int:0))) (String:"nSmP4vJF") (String:"y0loScB1") (((String:"127.0.0.1") (String:"4343")))) +Trying to connect to: 127.0.0.1:4240 +Recieved message as: 9o1aHTcp (4240) from: FxLP6Xqs +Sending message as: y0loScB1 to: nSmP4vJF + Over: 127.0.0.1:4343 + Message: NIntroduceNewPartnerAddress (String:"y0loScB1") (String:"4240") +Trying to connect to: 127.0.0.1:4343 +Sending message as: y0loScB1 to: nSmP4vJF + Over: 127.0.0.1:4343 +Message okay: NNewValue (String:"nSmP4vJF") (Int:1) (VInt (Int:1)) +Trying to connect to: 127.0.0.1:4340 + Message: NRequestSync (String:"y0loScB1") +Client connected: Introducing +Client connected: send message +Recieved message from unknown connection! + Response to m58eVfxV: NOkayIntroduce (String:"BV7wLFBf") + Message: NConversationMessage (String:"VTxR2xzx") (NIntroduceClient (String:"m58eVfxV") (String:"4343") (TName (Bool:False) (String:"SendSendIntClient"))) +Client connected: got answer +Client disconnected! +Finished Handshake +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 +Recieved message as: nSmP4vJF (4343) from: y0loScB1 + Message: NIntroduceClient (String:"m58eVfxV") (String:"4343") (TName (Bool:False) (String:"SendSendIntClient")) +Set RedirectRequest for y0loScB1 to 127.0.0.1:4340 +Took MVar for message: NConversationMessage (String:"KlPvDlGO") (NIntroduceNewPartnerAddress (String:"y0loScB1") (String:"4240")) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 +Trying to change the address to: 127.0.0.1:4240 +Put MVar for message: NConversationMessage (String:"KlPvDlGO") (NIntroduceNewPartnerAddress (String:"y0loScB1") (String:"4240")) + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) + Message: NConversationMessage (String:"KlPvDlGO") (NIntroduceNewPartnerAddress (String:"y0loScB1") (String:"4240")) +Recieved message as: nSmP4vJF (4343) from: y0loScB1 + Message: NConversationMessage (String:"7FR8CTTZ") (NRequestSync (String:"y0loScB1")) +Message okay: NIntroduceNewPartnerAddress (String:"y0loScB1") (String:"4240") + Message: NConversationMessage (String:"4fMWxwW4") (NNewValue (String:"FxLP6Xqs") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray [VInt (Int:1300)]) (Int:0))) (String:"nSmP4vJF") (String:"y0loScB1") (((String:"127.0.0.1") (String:"4343"))))) +Message okay: NRequestSync (String:"y0loScB1") +Got syncronization values: NOkaySync (SValuesArray [VInt (Int:1)]) +Message okay: NNewValue (String:"FxLP6Xqs") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray [VInt (Int:1300)]) (Int:0))) (String:"nSmP4vJF") (String:"y0loScB1") (((String:"127.0.0.1") (String:"4343")))) +Result: VInt 1 +ldgv: ldgv: : hGetLine: end of file +ldgv: : hGetLine: end of file +: hGetLine: end of fileldgv: : hGetLine: end of file + +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"nSmP4vJF") +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying +Trying to connect to: 127.0.0.1:4242 + Message: NConversationMessage (String:"TwS8y4jm") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Error when recieving response +Not connected to peer +Original message: NRequestSync (String:"nSmP4vJF") +Old communication partner offline! No longer retrying +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NNewValue (String:"nSmP4vJF") (Int:2) (VInt (Int:41)) +Trying to connect to: 127.0.0.1:4343 +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"BjdQRFgC") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NNewValue (String:"nSmP4vJF") (Int:2) (VInt (Int:41)) +Old communication partner offline! No longer retrying +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"UohqDYdS") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"GXNfJ7Yw") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"mDHQVSsA") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"XBxE6x6Y") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"FTezMCeI") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"HUL61CKa") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"WQwkpcTa") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"7CVpX7do") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"AlmTbNsu") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"dYvESZX1") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"5KI6rVpR") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"0EVbl7T6") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"zSAFR5ts") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"8XkNpQe4") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"E1QJbkIL") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"o2RMmriL") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"S1Rn7sOh") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"HjEwIYxC") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"yK7csElA") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"6xOE3t5Q") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"meKpjxJS") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"vPKDc5pN") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"Xh73nNHw") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"azJlN8EX") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"S2f1pHZk") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"FhGxPvQH") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"cPVqHGxm") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"sas5N9Tn") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"xXZHSQh7") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"dCpN5qnB") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"UVwrVwJa") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"npIaTvHJ") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"n3z3MXoW") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"ZzZzogKm") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"f1Uzlhwi") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"jQhzGDo9") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"qcxr5O8Z") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"ZLaI4TPK") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"ubQkIvZ3") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"tDK1U5SP") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +Error when recieving response +Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Old communication partner offline! New communication partner: 127.0.0.1:4340 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"z8xMNkdk") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: m58eVfxV to: BV7wLFBf + Over: 127.0.0.1:4340 + Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: BV7wLFBf (4340) from: m58eVfxV +Sending message as: BV7wLFBf to: m58eVfxV + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"BV7wLFBf") +Recieved message as: m58eVfxV (4343) from: BV7wLFBf + Message: NConversationMessage (String:"xaLWO908") (NRequestSync (String:"BV7wLFBf")) +Message okay: NRequestSync (String:"BV7wLFBf") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) +Sending message as: nSmP4vJF to: y0loScB1 + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +ldgv: Network.Socket.connect: : does not exist (Connection refused) +^CTerminated +[laeuferle@workbench ldgvnetworking]$ \ No newline at end of file diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 97a1a36..27708d0 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -104,6 +104,7 @@ interpret decls = do activeConnections <- NC.createActiveConnections MVar.putMVar sockets Map.empty R.runReaderT (interpretDecl decls) ([], (sockets, activeConnections)) + -- TODO Add check here to close all connections, and optionally synt to assure a good ending interpretDecl :: [Decl] -> InterpretM Value interpretDecl (DFun "main" _ e _:_) = interpret' e From 00de802b85c8bd53c46a5417860d8f701e745788 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 31 Jan 2023 16:20:18 +0100 Subject: [PATCH 093/229] Made fast networking more stable? --- src/Interpreter.hs | 5 +- src/Networking/Common.hs | 3 + src/Networking/Messages.hs | 1 + src/Networking/NetworkingMethod/Fast.hs | 68 ++++++++++++++++--- .../NetworkingMethodCommon.hs | 4 +- src/Networking/NetworkingMethod/Stateless.hs | 9 ++- src/Networking/Serialize.hs | 3 +- src/ValueParsing/ValueGrammar.y | 2 + src/ValueParsing/ValueTokens.x | 2 + test/Utils.hs | 13 ++-- 10 files changed, 89 insertions(+), 21 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 27708d0..b7d7378 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -103,8 +103,9 @@ interpret decls = do sockets <- MVar.newEmptyMVar activeConnections <- NC.createActiveConnections MVar.putMVar sockets Map.empty - R.runReaderT (interpretDecl decls) ([], (sockets, activeConnections)) - -- TODO Add check here to close all connections, and optionally synt to assure a good ending + result <- R.runReaderT (interpretDecl decls) ([], (sockets, activeConnections)) + NC.sayGoodbye activeConnections + return result interpretDecl :: [Decl] -> InterpretM Value interpretDecl (DFun "main" _ e _:_) = interpret' e diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 590f3c6..abb7f3a 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -9,6 +9,7 @@ import qualified Networking.Serialize as NSerialize import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG import qualified Config +-- import qualified Networking.NetworkingMethod.Stateless as NetMethod import qualified Networking.NetworkingMethod.Fast as NetMethod @@ -33,6 +34,8 @@ recieveResponse con waitTime tries = NetMethod.recieveResponse con waitTime trie endConversation con waitTime tries = NetMethod.endConversation con waitTime tries +sayGoodbye con = NetMethod.sayGoodbye con + {- getHandle :: Socket -> IO Handle getHandle socket = do diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs index 22d51b9..15e8f56 100644 --- a/src/Networking/Messages.hs +++ b/src/Networking/Messages.hs @@ -38,6 +38,7 @@ data Responses data ConversationSession = ConversationMessage ConversationID Messages | ConversationResponse ConversationID Responses + | ConversationCloseAll getUserID :: Messages -> String getUserID = \case diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index a422caf..728cb9f 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -45,7 +45,12 @@ conversationHandler handle = do mvar <- MVar.newEmptyMVar MVar.putMVar mvar Map.empty sem <- SSem.new 1 - forkIO $ forever (do + conversationHandlerChangeHandle handle chan mvar sem + +conversationHandlerChangeHandle handle chan mvar sem = do + isClosed <- MVar.newEmptyMVar + MVar.putMVar isClosed False + forkIO $ whileNotMVar isClosed (do -- Config.traceNetIO "Waiting for new conversation" Stateless.recieveMessageInternal handle VG.parseConversation (\_ -> return ()) (\mes des -> do -- Config.traceNetIO "Got new conversation" @@ -56,9 +61,22 @@ conversationHandler handle = do mymap <- MVar.takeMVar mvar MVar.putMVar mvar $ Map.insert cid (mes, response) mymap -- Config.traceNetIO "Set responses mvar" + ConversationCloseAll -> do + MVar.takeMVar isClosed + MVar.putMVar isClosed True + forkIO $ hClose handle + return () ) ) - return (handle, chan, mvar, sem) + return (handle, isClosed, chan, mvar, sem) + where + whileNotMVar :: MVar.MVar Bool -> IO () -> IO () + whileNotMVar mvar func = do + shouldStop <- MVar.readMVar mvar + unless shouldStop (do + _ <- func + whileNotMVar mvar func + ) recieveResponse :: Conversation -> Int -> Int -> IO (Maybe Responses) @@ -78,7 +96,7 @@ recieveResponse conversation@(cid, handle, mvar, sem) waitTime tries = do recieveResponse conversation waitTime $ max (tries-1) (-1) else return Nothing recieveNewMessage :: Connection -> IO (Conversation, String, Messages) -recieveNewMessage connection@(handle, chan, mvar, sem) = do +recieveNewMessage connection@(handle, isClosed, chan, mvar, sem) = do (cid, (serial, deserial)) <- Chan.readChan chan return ((cid, handle, mvar, sem), serial, deserial) @@ -88,15 +106,28 @@ startConversation acmvar hostname port waitTime tries = do conversationid <- newRandomUserID connectionMap <- MVar.takeMVar acmvar case Map.lookup (hostname, port) connectionMap of - Just (handle, chan, mvar, sem) -> do - MVar.putMVar acmvar connectionMap - return $ Just (conversationid, handle, mvar, sem) + Just (handle, isClosed, chan, mvar, sem) -> do + handleClosed <- MVar.readMVar isClosed + if handleClosed then do + statelessActiveCons <- Stateless.createActiveConnections + mbyNewHandle <- Stateless.startConversation statelessActiveCons hostname port waitTime tries + case mbyNewHandle of + Just handle -> do + newconnection@(handle, isClosed, chan, mvar, sem) <- conversationHandlerChangeHandle handle chan mvar sem + MVar.putMVar acmvar $ Map.insert (hostname, port) newconnection connectionMap + return $ Just (conversationid, handle, mvar, sem) + Nothing -> do + MVar.putMVar acmvar connectionMap + return Nothing + else do + MVar.putMVar acmvar connectionMap + return $ Just (conversationid, handle, mvar, sem) Nothing -> do statelessActiveCons <- Stateless.createActiveConnections mbyNewHandle <- Stateless.startConversation statelessActiveCons hostname port waitTime tries case mbyNewHandle of Just handle -> do - newconnection@(handle, chan, mvar, sem) <- conversationHandler handle + newconnection@(handle, isClosed, chan, mvar, sem) <- conversationHandler handle MVar.putMVar acmvar $ Map.insert (hostname, port) newconnection connectionMap return $ Just (conversationid, handle, mvar, sem) Nothing -> do @@ -165,7 +196,7 @@ acceptConversations ac connectionhandler port socketsmvar = do acceptClient :: ActiveConnectionsFast -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> String -> IO () acceptClient activeCons connectionhandler mvar clientlist clientsocket ownport = do hdl <- Stateless.getSocketFromHandle $ fst clientsocket - connection@(handle, chan, responsesMvar, sem) <- conversationHandler hdl + connection@(handle, isClosed, chan, responsesMvar, sem) <- conversationHandler hdl -- NC.recieveMessage hdl VG.parseMessages (\_ -> return ()) $ connectionhandler mvar clientlist clientsocket hdl ownport forkIO $ forever (do (conversationid, (serial, deserial)) <- Chan.readChan chan @@ -178,3 +209,24 @@ acceptConversations ac connectionhandler port socketsmvar = do endConversation :: Conversation -> Int -> Int -> IO () endConversation _ _ _ = return () +sayGoodbye :: ActiveConnectionsFast -> IO () +sayGoodbye activeCons = do + activeConsMap <- MVar.readMVar activeCons + let connections = Map.elems activeConsMap + runAll sayGoodbyeConnection connections + where + sayGoodbyeConnection :: Connection -> IO () + sayGoodbyeConnection connection@(handle, isClosed, messages, responses, sem) = do + handleClosed <- MVar.readMVar isClosed + unless handleClosed $ SSem.withSem sem $ Stateless.sendMessage handle ConversationCloseAll + unless handleClosed $ SSem.withSem sem $ hPutStr handle " " + hFlushAll handle + forkIO $ hClose handle + return () + runAll _ [] = return () + runAll f (x:xs) = do + _ <- f x + runAll f xs + + + diff --git a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs index c77e1b8..7186047 100644 --- a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs +++ b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs @@ -13,8 +13,8 @@ type ActiveConnections = ActiveConnectionsFast data ActiveConnectionsStateless = ActiveConnectionsStateless -type Connection = (Handle, Chan.Chan (String, (String, Messages)), MVar.MVar (Map.Map String (String, Responses)), SSem.SSem) --- Conversationid serial deserial +type Connection = (Handle, MVar.MVar Bool, Chan.Chan (String, (String, Messages)), MVar.MVar (Map.Map String (String, Responses)), SSem.SSem) +-- isClosed Conversationid serial deserial type ActiveConnectionsFast = MVar.MVar (Map.Map NetworkAddress Connection) type NetworkAddress = (String, String) diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index 56463a0..51d3fc1 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -161,5 +161,10 @@ openSocketNC addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol getSocketFromHandle :: Socket -> IO Handle getSocketFromHandle socket = do hdl <- socketToHandle socket ReadWriteMode - hSetBuffering hdl NoBuffering - return hdl \ No newline at end of file + -- hSetBuffering hdl NoBuffering + hSetBuffering hdl LineBuffering + return hdl + + +sayGoodbye :: ActiveConnectionsStateless -> IO () +sayGoodbye _ = return () \ No newline at end of file diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index 4920618..58f2653 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -34,7 +34,8 @@ class Serializable a where instance Serializable ConversationSession where serialize = \case ConversationMessage c m -> serializeLabeledEntryMulti "NConversationMessage" c $ sLast m - ConversationResponse c r -> serializeLabeledEntryMulti "NConversationResponse" c $ sLast r + ConversationResponse c r -> serializeLabeledEntryMulti "NConversationResponse" c $ sLast r + ConversationCloseAll -> return "NConversationCloseAll" instance Serializable Responses where serialize = \case diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 1c4b63f..e6a1b44 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -133,6 +133,7 @@ import Networking.Messages nwait { T _ T.NWait} nconversationmessage { T _ T.NConversationMessage} nconversationresponse { T _ T.NConversationResponse} + nconversationcloseall { T _ T.NConversationCloseAll } gunit { T _ T.GUnit } glabel { T _ T.GLabel } @@ -303,6 +304,7 @@ Responses : nredirect '(' String ')' '(' String ')' {Redirect $3 $6} ConversationSession : nconversationmessage '(' String ')' '(' Messages ')' {ConversationMessage $3 $6} | nconversationresponse '(' String ')' '(' Responses ')' {ConversationResponse $3 $6} + | nconversationcloseall {ConversationCloseAll} PEnvEntry : penventry '(' String ')' '(' Values ')' {($3, $6)} diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index 162222c..0bf450c 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -145,6 +145,7 @@ tokens :- "NWait" { tok $ const NWait} "NConversationMessage" { tok $ const NConversationMessage } "NConversationResponse" { tok $ const NConversationResponse } + "NConversationCloseAll" { tok $ const NConversationCloseAll } Double\:[\-]?[0-9]+[\.][0-9]+ { tok $ Double . read . (drop 7) } Int\:[\-]?[0-9]+ { tok $ Int . read . (drop 4)} @@ -276,6 +277,7 @@ data Token | NWait | NConversationMessage | NConversationResponse + | NConversationCloseAll | String String | Int Int diff --git a/test/Utils.hs b/test/Utils.hs index 09287d1..c901572 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -5,8 +5,9 @@ import Syntax import Interpreter import ProcessEnvironment import ProcessEnvironmentTypes -import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC -import qualified Networking.NetworkingMethod.Stateless as Stateless +-- import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC +-- import qualified Networking.NetworkingMethod.Stateless as Stateless +import qualified Networking.Common as NC import Control.Monad.Reader (runReaderT) import Test.Hspec import Control.Concurrent.MVar @@ -24,7 +25,7 @@ raiseFailure msg = do shouldInterpretTo :: [Decl] -> Value -> Expectation shouldInterpretTo givenDecls expectedValue = do sockets <- newEmptyMVar - handles <- Stateless.createActiveConnections + handles <- NC.createActiveConnections putMVar sockets Map.empty value <- runReaderT (interpretDecl givenDecls) ([], (sockets, handles)) value `shouldBe` expectedValue @@ -36,21 +37,21 @@ shouldThrowCastException givenDecls = isCastException _ = False in do sockets <- newEmptyMVar - handles <- Stateless.createActiveConnections + handles <- NC.createActiveConnections putMVar sockets Map.empty runReaderT (interpretDecl givenDecls) ([], (sockets, handles)) `shouldThrow` isCastException shouldThrowInterpreterException :: Decl -> InterpreterException -> Expectation shouldThrowInterpreterException given except = do sockets <- newEmptyMVar - handles <- Stateless.createActiveConnections + handles <- NC.createActiveConnections putMVar sockets Map.empty runReaderT (interpretDecl [given]) ([], (sockets, handles)) `shouldThrow` (== except) shouldInterpretTypeTo :: Type -> NFType -> Expectation shouldInterpretTypeTo t expected = do sockets <- newEmptyMVar - handles <- Stateless.createActiveConnections + handles <- NC.createActiveConnections putMVar sockets Map.empty nft <- runReaderT (evalType t) ([], (sockets, handles)) nft `shouldBe` expected From 7d414914b54dec3a7059c702d1c7454fb63e2ee9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 31 Jan 2023 17:48:27 +0100 Subject: [PATCH 094/229] EOF checks --- src/Networking/NetworkingMethod/Fast.hs | 4 +++- src/Networking/NetworkingMethod/Stateless.hs | 12 ++++++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index 728cb9f..80c3cfc 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -64,7 +64,9 @@ conversationHandlerChangeHandle handle chan mvar sem = do ConversationCloseAll -> do MVar.takeMVar isClosed MVar.putMVar isClosed True - forkIO $ hClose handle + forkIO (do + closed <- hIsClosed handle + unless closed $ hClose handle) return () ) ) diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index 51d3fc1..fbb4c6a 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -9,6 +9,7 @@ import qualified Control.Concurrent.MVar as MVar import qualified Data.Map as Map import qualified Data.Maybe import Control.Concurrent +import Control.Monad import Networking.Messages import Networking.NetworkConnection @@ -32,6 +33,7 @@ sendResponse = sendMessage recieveMessageInternal :: Handle -> VT.Alex t -> (String -> IO b) -> (String -> t -> IO b) -> IO b recieveMessageInternal handle grammar fallbackResponse messageHandler = do + waitWhileEOF handle message <- hGetLine handle case VT.runAlex message grammar of Left err -> do @@ -41,6 +43,16 @@ recieveMessageInternal handle grammar fallbackResponse messageHandler = do -- Config.traceNetIO $ "New superficially valid message recieved: "++message messageHandler message deserialmessage + +waitWhileEOF :: Handle -> IO () +waitWhileEOF handle = do + isEOF <- hIsEOF handle + when isEOF (do + threadDelay 10000 + waitWhileEOF handle + ) + + startConversation :: ActiveConnectionsStateless -> String -> String -> Int -> Int -> IO (Maybe Handle) startConversation _ hostname port waitTime tries = do let hints = defaultHints { From bab98a7a998dfccd7d0724817a7819f4db70661c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 1 Feb 2023 11:49:23 +0100 Subject: [PATCH 095/229] Removed deadcode --- src/Interpreter.hs | 23 ----------------------- src/Networking/Messages.hs | 6 +----- src/Networking/Serialize.hs | 4 ---- src/Parsing/Grammar.y | 6 ------ src/Parsing/Tokens.x | 4 ---- src/PrettySyntax.hs | 2 -- src/Syntax.hs | 6 ------ src/TCTyping.hs | 4 ---- src/ValueParsing/ValueGrammar.y | 8 +------- src/ValueParsing/ValueTokens.x | 6 ------ 10 files changed, 2 insertions(+), 67 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index b7d7378..31b71dd 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -212,30 +212,7 @@ eval = \case -- Disable the old channel and get a new one newV <- liftIO $ disableOldVChan v return $ VPair val newV - End e -> do - liftIO $ C.traceIO "Trying to close a connection" - interpret' e >>= \v@(VChan ci mvar usedmvar) -> do - used <- liftIO $ MVar.readMVar usedmvar - if used then throw $ VChanIsUsedException $ show v else do - liftIO $ C.traceIO $ "Trying to close connection with:" ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID ci) - liftIO $ NClient.closeConnection ci - - -- Disable the channel - _ <- liftIO $ disableOldVChan v - return v Case e cases -> interpret' e >>= \(VLabel s) -> interpret' $ fromJust $ lookup s cases - {- Create e -> do - liftIO $ C.traceIO "Creating socket!" - - val <- interpret' e - case val of - VInt port -> do - (_, (_, activeConnections)) <- ask - (mvar, clientlist) <- liftIO $ NetMethod.acceptConversations activeConnections NS.handleClient port - liftIO $ C.traceIO "Socket created" - return $ VServerSocket mvar clientlist $ show port - _ -> throw $ NotAnExpectedValueException "VInt" val - -} Accept e t -> do liftIO $ C.traceIO "Accepting new client!" diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs index 15e8f56..8fc061d 100644 --- a/src/Networking/Messages.hs +++ b/src/Networking/Messages.hs @@ -16,9 +16,7 @@ type ConversationID = String -- I need to add the Port to every introduction so I can answer oder alles muss mit einem okay quitiert werden, dann kann die antwort gesendet werden data Messages - = Introduce UserID - | IntroduceClient UserID Port Type - | IntroduceServer UserID + = IntroduceClient UserID Port Type | NewValue UserID Int Value | SyncIncoming UserID [Value] | RequestSync UserID @@ -42,9 +40,7 @@ data ConversationSession getUserID :: Messages -> String getUserID = \case - Introduce p -> p IntroduceClient p _ _ -> p - IntroduceServer p -> p NewValue p _ _ -> p SyncIncoming p _ -> p RequestSync p -> p diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index 58f2653..da17ea2 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -48,9 +48,7 @@ instance Serializable Responses where instance Serializable Messages where serialize = \case - Introduce p -> serializeLabeledEntry "NIntroduce" p IntroduceClient p port t -> serializeLabeledEntryMulti "NIntroduceClient" p $ sNext port $ sLast t - IntroduceServer p -> serializeLabeledEntry "NIntroduceServer" p NewValue p c v -> serializeLabeledEntryMulti "NNewValue" p $ sNext c $ sLast v SyncIncoming p vs -> serializeLabeledEntryMulti "NSyncIncoming" p $ sLast vs RequestSync p -> serializeLabeledEntry "NRequestSync" p @@ -150,10 +148,8 @@ instance Serializable Exp where Case e arr -> serializeLabeledEntryMulti "ECase" e $ sLast arr Cast e t1 t2 -> serializeLabeledEntryMulti "ECast" e $ sNext t1 $ sLast t2 - Create e -> serializeLabeledEntry "ECreate" e Connect e0 t e1 e2 -> serializeLabeledEntryMulti "EConnect" e0 $ sNext t $ sNext e1 $ sLast e2 Accept e t -> serializeLabeledEntryMulti "EAccept" e $ sLast t - End e -> serializeLabeledEntry "EEnd" e instance Serializable (MathOp Exp) where serialize = \case diff --git a/src/Parsing/Grammar.y b/src/Parsing/Grammar.y index cd23aac..c4ab4d7 100644 --- a/src/Parsing/Grammar.y +++ b/src/Parsing/Grammar.y @@ -36,10 +36,8 @@ import qualified Parsing.Tokens as T new { T _ T.New } send { T _ T.Send } recv { T _ T.Recv } - create { T _ T.Create } connect { T _ T.Connect } accept { T _ T.Accept } - end { T _ T.End } -- for Binary Session Types; obsolete for Label Dependent ones select { T _ T.Select } @@ -170,10 +168,6 @@ Exp : let var '=' Exp in Exp %prec LET { Let $2 $4 $6 } | fork Exp { Fork $2 } | send Exp %prec send { Send $2 } | recv Exp %prec recv { Recv $2 } - | create Exp %prec create { Create $2 } - | end Exp %prec end { End $2 } --- | connect Exp Exp Exp Typ %prec connect { Connect $2 $3 $4 $5 } --- | connect Exp Typ Exp Exp %prec connect { Connect $2 $4 $5 $3} | connect Exp Typ Exp Exp %prec connect {Connect $2 $3 $4 $5} | accept Exp Typ %prec accept { Accept $2 $3 } | Exp Exp %prec APP { App $1 $2 } diff --git a/src/Parsing/Tokens.x b/src/Parsing/Tokens.x index 0134601..b29b052 100644 --- a/src/Parsing/Tokens.x +++ b/src/Parsing/Tokens.x @@ -42,10 +42,8 @@ tokens :- new { tok $ const New } send { tok $ const Send } recv { tok $ const Recv } - create { tok $ const Create } connect { tok $ const Connect } accept { tok $ const Accept } - end { tok $ const End } -- for Binary Session Types; obsolete for Label Dependent ones select { tok $ const Select } @@ -100,10 +98,8 @@ data Token = New | Send | Recv | - Create | Connect | Accept | - End | -- for Binary Session Types; obsolete for Label Dependent ones Select | diff --git a/src/PrettySyntax.hs b/src/PrettySyntax.hs index e3f1012..123e2f0 100644 --- a/src/PrettySyntax.hs +++ b/src/PrettySyntax.hs @@ -125,8 +125,6 @@ instance Pretty Exp where pretty (New t) = pretty "new" <+> pretty t pretty (Send e) = pretty "send" <+> pretty e pretty (Recv e) = pretty "recv" <+> pretty e - pretty (End e) = pretty "end" <+> pretty e - pretty (Create i) = pretty "create" <+> pretty i pretty (Connect s t a i) = pretty "connect" <+> pretty s <+> pretty t <+> pretty a <+> pretty i pretty (Accept s t) = pretty "accept" <+> pretty s <+> pretty t pretty (Case e ses) = diff --git a/src/Syntax.hs b/src/Syntax.hs index fd513ed..c67594f 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -33,10 +33,8 @@ data Exp = Let Ident Exp Exp | Case Exp [(String, Exp)] | Cast Exp Type Type -- New types - | Create Exp -- Create Port | Connect Exp Type Exp Exp -- Connect URL Port Type | Accept Exp Type -- Accept Socket Type - | End Exp -- End Connection deriving (Show,Eq) data MathOp e @@ -171,10 +169,8 @@ instance Freevars Exp where fv (New ty) = fv ty fv (Send e1) = fv e1 fv (Recv e1) = fv e1 - fv (Create e1) = fv e1 fv (Connect e0 ty e1 e2) = fv e0 <> fv ty <>fv e1 <> fv e2 fv (Accept e1 ty) = fv e1 <> fv ty - fv (End e1) = fv e1 fv (Case e cases) = foldl' (<>) (fv e) $ map (fv . snd) cases fv (Cast e t1 t2) = fv e fv (Succ e) = fv e @@ -242,8 +238,6 @@ instance Substitution Exp where sb (New t) = New t sb (Send e1) = Send (sb e1) sb (Recv e1) = Recv (sb e1) - sb (Create e1) = Create (sb e1) - sb (End e1) = End (sb e1) sb (Connect e0 t e1 e2) = Connect (sb e0) t (sb e1) (sb e2) sb (Accept e1 t) = Accept (sb e1) t sb (Succ e1) = Succ (sb e1) diff --git a/src/TCTyping.hs b/src/TCTyping.hs index b68ae7a..9c4e62e 100644 --- a/src/TCTyping.hs +++ b/src/TCTyping.hs @@ -243,10 +243,6 @@ tySynth te e = kiCheck (demoteTE te) ty Kssn return (TPair "" ty (dualof ty), te) -- I've got no real clue of what I am doing here hope it kind of works - Create e1 -> do - return (TDyn, te) - End e1 -> do - return (TServerSocket, te) Connect e0 ty e1 e2 -> do kiCheck (demoteTE te) ty Kssn return (ty, te) diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index e6a1b44..0bbae4e 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -87,7 +87,6 @@ import Networking.Messages erecv { T _ T.ERecv } ecase { T _ T.ECase } ecast { T _ T.ECast } - eend { T _ T.EEnd } madd { T _ T.MAdd } msub { T _ T.MSub } @@ -116,9 +115,7 @@ import Networking.Messages sdirectionalconnection {T _ T.SDirectionalConnection} sconnected {T _ T.SConnected} - nintroduce { T _ T.NIntroduce } nintroduceclient { T _ T.NIntroduceClient } - nintroduceserver { T _ T.NIntroduceServer } nnewvalue { T _ T.NNewValue } nsyncincoming { T _ T.NSyncIncoming } nrequestsync { T _ T.NRequestSync } @@ -266,7 +263,6 @@ Exp : elet '(' String ')' '(' Exp ')' '(' Exp ')' {Let $3 $6 $9} | erecv '(' Exp ')' {Recv $3} | ecase '(' Exp ')' '(' SStringExpArray ')' {Case $3 $6} | ecast '(' Exp ')' '(' Type ')' '(' Type ')' {Cast $3 $6 $9} - | eend '(' Exp ')' {End $3} MathOp : madd '(' Exp ')' '(' Exp ')' {Add $3 $6} @@ -285,9 +281,7 @@ GType : gunit {GUnit} | gdouble {GDouble} | gstring {GString} -Messages : nintroduce '(' String ')' {Introduce $3} - | nintroduceclient '(' String ')' '(' String ')' '(' Type ')' {IntroduceClient $3 $6 $9} - | nintroduceserver '(' String ')' {IntroduceServer $3} +Messages : nintroduceclient '(' String ')' '(' String ')' '(' Type ')' {IntroduceClient $3 $6 $9} | nnewvalue '(' String ')' '(' int ')' '(' Values ')' {NewValue $3 $6 $9} | nsyncincoming '(' String ')''(' SValuesArray ')' {SyncIncoming $3 $6} | nrequestsync '(' String ')' {RequestSync $3} diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index 0bf450c..5de9fea 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -87,7 +87,6 @@ tokens :- "ERecv" { tok $ const ERecv } "ECase" { tok $ const ECase } "ECast" { tok $ const ECast } - "EEnd" { tok $ const EEnd } "MAdd" { tok $ const MAdd } "MSub" { tok $ const MSub } @@ -128,9 +127,7 @@ tokens :- "SDirectionalConnection" { tok $ const SDirectionalConnection} "SConnected" { tok $ const SConnected} - "NIntroduce" { tok $ const NIntroduce } "NIntroduceClient" { tok $ const NIntroduceClient } - "NIntroduceServer" { tok $ const NIntroduceServer } "NNewValue" { tok $ const NNewValue } "NSyncIncoming" { tok $ const NSyncIncoming } "NRequestSync" { tok $ const NRequestSync } @@ -216,7 +213,6 @@ data Token | ERecv | ECase | ECast - | EEnd | MAdd | MSub @@ -260,9 +256,7 @@ data Token | SDirectionalConnection | SConnected - | NIntroduce | NIntroduceClient - | NIntroduceServer | NNewValue | NSyncIncoming | NRequestSync From 2d919645e9f78776fea0b156261f5601cddedcf0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 1 Feb 2023 11:54:42 +0100 Subject: [PATCH 096/229] Removed more deadcode --- src/Networking/Client.hs | 130 +-------------------------------------- src/Networking/Common.hs | 24 +------- 2 files changed, 2 insertions(+), 152 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index a3758ea..34b98b2 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -76,38 +76,6 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen Config.traceNetIO $ "Sending message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection) ++ " to: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkconnection) Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port Config.traceNetIO $ " Message: " ++ serializedMessage - {- - let hints = defaultHints { - addrFamily = AF_INET - , addrFlags = [] - , addrSocketType = Stream - } - connectionsuccessful <- MVar.newEmptyMVar - MVar.putMVar connectionsuccessful False - response <- MVar.newEmptyMVar - threadid <- forkIO (do - Config.traceNetIO $ "Trying to connect to: " ++ hostname ++":"++port - addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port - -- Config.traceNetIO "Trying to open socket" - clientsocket <- NC.openSocketNC $ head addrInfo - -- Config.traceNetIO "Trying to connect" - -- This sometimes fails - connect clientsocket $ addrAddress $ head addrInfo - _ <- MVar.takeMVar connectionsuccessful - MVar.putMVar connectionsuccessful True - -- Config.traceNetIO "Connected" - handle <- NC.getHandle clientsocket - -- Config.traceNetIO "Trying to send!" - NC.sendMessage message handle - - -- Config.traceNetIO "Waiting for response" - mbyresponse <- recieveResponse handle - hClose handle - MVar.putMVar response mbyresponse - ) - mbyresponse <- getResp threadid connectionsuccessful response 10 - -} - mbycon <- NC.startConversation activeCons hostname port 10000 100 mbyresponse <- case mbycon of @@ -150,23 +118,6 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen else Config.traceNetIO "Old communication partner offline! No longer retrying" _ -> Config.traceNetIO "Error when sending message: This channel is disconnected while sending" -{- - where - getResp :: ThreadId -> MVar.MVar Bool -> MVar.MVar (Maybe Responses) -> Int -> IO (Maybe Responses) - getResp threadid connectedmvar mbyResponse count = do - res <- tryTakeMVar mbyResponse - case res of - Just response -> return response - Nothing -> if count /= 0 then do - threadDelay 100000 - connected <- MVar.readMVar connectedmvar - if connected then getResp threadid connectedmvar mbyResponse $ max (count-1) (-1) else do - killThread threadid - return Nothing - else do - killThread threadid - return Nothing --} printConErr :: String -> String -> IOException -> IO () printConErr hostname port err = Config.traceIO $ "Communication Partner " ++ hostname ++ ":" ++ port ++ "not found!" @@ -251,72 +202,6 @@ sendVChanMessages newhost newport input = case input of sendVChanMessages newhost newport $ snd x sendVChanMessagesPEnv newhost newport xs -closeConnection _ = return () - --- Close Connection is no longer needed -{- -closeConnection :: NetworkConnection Value -> IO () -closeConnection con = do - connectionstate <- MVar.readMVar $ ncConnectionState con - case connectionstate of - NCon.Connected hostname port -> do - connectionError <- MVar.newEmptyMVar - MVar.putMVar connectionError False - catch ( tryToSendNetworkMessage con hostname port (RequestClose $ Data.Maybe.fromMaybe "" $ ncOwnUserID con) 0) (\exception -> do - printConErr hostname port exception - _ <- MVar.takeMVar connectionError -- If we cannot communicate with them just close the connection - MVar.putMVar connectionError True - ) - errorOccured <- MVar.readMVar connectionError - if errorOccured then return () else do - shouldClose <- MVar.readMVar $ ncRecievedRequestClose con - if shouldClose then do - Config.traceIO "Closing handshake completed" - return () - else do - threadDelay 1000000 - closeConnection con - NCon.Emulated -> pure () - _ -> Config.traceIO "Error when sending message: This channel is disconnected" --} -{- -recieveResponse :: Handle -> IO (Maybe Responses) -recieveResponse handle = do - retVal <- MVar.newEmptyMVar - forkIO $ NC.recieveMessage handle VG.parseResponses (\_ -> MVar.putMVar retVal Nothing) (\_ des -> MVar.putMVar retVal $ Just des) - waitForResponse retVal 100 - where - waitForResponse :: MVar.MVar (Maybe Responses) -> Int -> IO (Maybe Responses) - waitForResponse mvar count = do - result <- MVar.tryTakeMVar mvar - case result of - Just mbyResponse -> do - -- Config.traceNetIO "Got response" - return mbyResponse - Nothing -> if count /= 0 then do - -- Config.traceNetIO $ "Waiting for response: " ++ show count - threadDelay 10000 - waitForResponse mvar (count-1) - else return Nothing - --- This waits until the handle is established -getClientHandle :: String -> String -> IO Handle -getClientHandle hostname port = do - catch ( do - let hints = defaultHints { - addrFlags = [] - , addrSocketType = Stream - } - addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port - clientsocket <- NC.openSocketNC $ head addrInfo - connect clientsocket $ addrAddress $ head addrInfo - NC.getHandle clientsocket) $ expredirect hostname port - where - expredirect :: String -> String -> IOException -> IO Handle - expredirect hostname port e = do - threadDelay 1000000 - getClientHandle hostname port --} replaceVChan :: Value -> IO Value replaceVChan input = case input of VSend v -> do @@ -351,17 +236,4 @@ replaceVChan input = case input of replaceVChanPEnv (x:xs) = do newval <- replaceVChan $ snd x rest <- replaceVChanPEnv xs - return $ (fst x, newval):rest - -{- -waitForServerIntroduction :: Handle -> IO String -waitForServerIntroduction handle = do - NC.recieveMessage handle VG.parseResponses (throw . NoIntroductionException) deserHandler - where - deserHandler message deserial = case deserial of - OkayIntroduce partner -> do - return partner - _ -> do - Config.traceIO $ "Error during server introduction, wrong message: "++ message - throw $ NoIntroductionException message --} \ No newline at end of file + return $ (fst x, newval):rest \ No newline at end of file diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index abb7f3a..9ce0aaa 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -34,26 +34,4 @@ recieveResponse con waitTime tries = NetMethod.recieveResponse con waitTime trie endConversation con waitTime tries = NetMethod.endConversation con waitTime tries -sayGoodbye con = NetMethod.sayGoodbye con - -{- -getHandle :: Socket -> IO Handle -getHandle socket = do - hdl <- socketToHandle socket ReadWriteMode - hSetBuffering hdl NoBuffering - return hdl - -recieveMessage :: Handle -> VT.Alex t -> (String -> IO b) -> (String -> t -> IO b) -> IO b -recieveMessage handle grammar fallbackResponse messageHandler = do - message <- hGetLine handle - case VT.runAlex message grammar of - Left err -> do - Config.traceNetIO $ "Error during recieving a networkmessage: "++err - fallbackResponse message - Right deserialmessage -> do - -- Config.traceNetIO $ "New superficially valid message recieved: "++message - messageHandler message deserialmessage - -openSocketNC :: AddrInfo -> IO Socket -openSocketNC addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) --} \ No newline at end of file +sayGoodbye con = NetMethod.sayGoodbye con \ No newline at end of file From facbaaf07d5704052a418b2d512b70d8ab9731c8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 1 Feb 2023 14:29:37 +0100 Subject: [PATCH 097/229] Caught some potential exceptions --- src/Networking/Client.hs | 6 +----- src/Networking/NetworkingMethod/Fast.hs | 13 ++++++++++--- src/Networking/NetworkingMethod/Stateless.hs | 14 +++++++++++--- 3 files changed, 22 insertions(+), 11 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 34b98b2..af0c894 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -119,6 +119,7 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen _ -> Config.traceNetIO "Error when sending message: This channel is disconnected while sending" + printConErr :: String -> String -> IOException -> IO () printConErr hostname port err = Config.traceIO $ "Communication Partner " ++ hostname ++ ":" ++ port ++ "not found!" @@ -131,17 +132,12 @@ initialConnect activeCons mvar hostname port ownport syntype= do case mbycon of Just con -> do ownuserid <- UserID.newRandomUserID - Config.traceNetIO "Client connected: Introducing" NC.sendMessage con (Messages.IntroduceClient ownuserid ownport syntype) - Config.traceNetIO "Client connected: send message" mbyintroductionanswer <- NC.recieveResponse con 10000 (-1) - Config.traceNetIO "Client connected: got answer" NC.endConversation con 10000 10 - Config.traceNetIO "Client disconnected!" case mbyintroductionanswer of Just introduction -> case introduction of OkayIntroduce introductionanswer -> do - Config.traceNetIO "Finished Handshake" msgserial <- NSerialize.serialize $ Messages.IntroduceClient ownuserid ownport syntype Config.traceNetIO $ "Sending message as: " ++ ownuserid ++ " to: " ++ introductionanswer Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index 80c3cfc..4197682 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -10,6 +10,7 @@ import qualified Data.Maybe import qualified Data.Map as Map import Control.Concurrent import Control.Monad +import Control.Exception import Networking.Messages import Networking.NetworkConnection @@ -62,11 +63,12 @@ conversationHandlerChangeHandle handle chan mvar sem = do MVar.putMVar mvar $ Map.insert cid (mes, response) mymap -- Config.traceNetIO "Set responses mvar" ConversationCloseAll -> do + Config.traceNetIO $ "Recieved Message: " ++ mes MVar.takeMVar isClosed MVar.putMVar isClosed True - forkIO (do + forkIO $ catch (do closed <- hIsClosed handle - unless closed $ hClose handle) + unless closed $ hClose handle) onException return () ) ) @@ -79,6 +81,9 @@ conversationHandlerChangeHandle handle chan mvar sem = do _ <- func whileNotMVar mvar func ) + onException :: IOException -> IO () + onException _ = return () + recieveResponse :: Conversation -> Int -> Int -> IO (Maybe Responses) @@ -223,12 +228,14 @@ sayGoodbye activeCons = do unless handleClosed $ SSem.withSem sem $ Stateless.sendMessage handle ConversationCloseAll unless handleClosed $ SSem.withSem sem $ hPutStr handle " " hFlushAll handle - forkIO $ hClose handle + forkIO $ catch (hClose handle) onException return () runAll _ [] = return () runAll f (x:xs) = do _ <- f x runAll f xs + onException :: IOException -> IO () + onException _ = return () diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index fbb4c6a..2cb9ca6 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -10,6 +10,7 @@ import qualified Data.Map as Map import qualified Data.Maybe import Control.Concurrent import Control.Monad +import Control.Exception import Networking.Messages import Networking.NetworkConnection @@ -46,11 +47,14 @@ recieveMessageInternal handle grammar fallbackResponse messageHandler = do waitWhileEOF :: Handle -> IO () waitWhileEOF handle = do - isEOF <- hIsEOF handle + isEOF <- catch (hIsEOF handle) onException when isEOF (do threadDelay 10000 waitWhileEOF handle ) + where + onException :: IOException -> IO Bool + onException _ = return True startConversation :: ActiveConnectionsStateless -> String -> String -> Int -> Int -> IO (Maybe Handle) @@ -61,16 +65,20 @@ startConversation _ hostname port waitTime tries = do , addrSocketType = Stream } handleMVar <- MVar.newEmptyMVar - threadid <- forkIO (do + threadid <- forkIO $ catch (do Config.traceNetIO $ "Trying to connect to: " ++ hostname ++":"++port addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port clientsocket <- openSocketNC $ head addrInfo connect clientsocket $ addrAddress $ head addrInfo handle <- getSocketFromHandle clientsocket MVar.putMVar handleMVar handle - ) + ) $ printConErr hostname port getFromNetworkThread threadid handleMVar waitTime tries + +printConErr :: String -> String -> IOException -> IO () +printConErr hostname port err = Config.traceIO $ "startConversation: Communication Partner " ++ hostname ++ ":" ++ port ++ "not found!" + waitForConversation :: ActiveConnectionsStateless -> String -> String -> Int -> Int -> IO (Maybe Handle) waitForConversation ac hostname port waitTime tries = do mbyHandle <- startConversation ac hostname port waitTime tries From d8263b4675632f25516a54db31d1a2ad98afb1cd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 1 Feb 2023 17:25:23 +0100 Subject: [PATCH 098/229] Some buglogs with their hopeful solution --- FastNetworkingBug2.log | 927 +++++++++++++++++++ FastNetworkingBug3.log | 706 ++++++++++++++ src/Networking/Client.hs | 8 +- src/Networking/NetworkingMethod/Fast.hs | 3 +- src/Networking/NetworkingMethod/Stateless.hs | 24 +- src/Networking/Server.hs | 1 + testOftenHandoff4.sh | 3 + 7 files changed, 1656 insertions(+), 16 deletions(-) create mode 100644 FastNetworkingBug2.log create mode 100644 FastNetworkingBug3.log create mode 100644 testOftenHandoff4.sh diff --git a/FastNetworkingBug2.log b/FastNetworkingBug2.log new file mode 100644 index 0000000..ce672e2 --- /dev/null +++ b/FastNetworkingBug2.log @@ -0,0 +1,927 @@ +29 Handoff4 +subtype: Entering [(c, (0, SendInt))] (Nat) (Int) +subtype: Entering [(x, (0, !Int. ())), (c, (0, SendInt))] (Nat) (Int) +subtype: Entering [ (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (SendOneInt) +subtype: Entering [ (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) +subtype: Entering [ (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz5, (_, Int)) +, (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +subtype: Entering [ (z, (_, ())) +, (n, (_, Int)) +, (x, (_, ())) +, (oneint, (0, SendOneInt)) +, (y, (0, ?SendOneInt. ())) +, (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (z, (_, ())) +, (n, (_, Int)) +, (x, (_, ())) +, (oneint, (0, SendOneInt)) +, (y, (0, ?SendOneInt. ())) +, (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (~SendInt) (~SendInt) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (~SendInt) (?Int. ?Int. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ?Int. ()) (?Int. ?Int. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz6, (_, Int)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) +subtype: Entering [ (zz6, (_, Int)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (zz6, (_, Int)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz7, (_, Int)) +, (zz6, (_, Int)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendSendOneInt) (SendSendOneInt) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendSendOneInt) (!SendOneInt. ?SendOneInt. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (!SendOneInt. ?SendOneInt. ()) (!SendOneInt. ?SendOneInt. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) +subtype: Entering [ (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (SendOneInt) (SendOneInt) +subtype: Entering [ (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (SendOneInt) (?Int. ()) +subtype: Entering [ (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (?Int. ()) (?Int. ()) +subtype: Entering [ (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (Int) (Int) +subtype: [ (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz5, (_, Int)) +, (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (()) (()) +subtype: Entering [(main, (_, ()))] (()) (()) +Trying to connect to: 127.0.0.1:4242 +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (?Int. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz6, (_, Int)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +subtype: [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) = Kssn +subtype: [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (?Int. ()) = Kssn +subtype: [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) = Kssn +subtype: Entering [(c, (0, SendInt))] (Nat) (Int) +subtype: Entering [(x, (0, !Int. ())), (c, (0, SendInt))] (Nat) (Int) +subtype: Entering [ (c3, (_, ())) +, (n, (_, Int)) +, (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (c3, (_, ())) +, (n, (_, Int)) +, (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendInt) (SendInt) +subtype: Entering [ (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendInt) (!Int. !Int. ()) +subtype: Entering [ (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (!Int. !Int. ()) (!Int. !Int. ()) +subtype: Entering [ (zz6, (0, SendOneInt)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (?SendOneInt. ()) (?SendOneInt. ()) +subtype: Entering [ (zz6, (0, SendOneInt)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) +subtype: [ (zz6, (0, SendOneInt)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) = Kssn +subtype: Entering [ (zz7, (0, SendOneInt)) +, (zz6, (0, SendOneInt)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +subtype: Entering [ (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz5, (_, Int)) +, (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (!Int. ()) (!Int. ()) +subtype: Entering [ (zz5, (_, Int)) +, (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (zz5, (_, Int)) +, (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz6, (_, Int)) +, (zz5, (_, Int)) +, (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +subtype: Entering [ (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +Trying to connect to: 127.0.0.1:4242 +Recieved message from unknown connection! + Response to bo2qSbvH: NOkayIntroduce (String:"MgqsgbDo") + Message: NConversationMessage (String:"CYqgTOMK") (NIntroduceClient (String:"bo2qSbvH") (String:"4444") (TName (Bool:False) (String:"SendInt"))) +Sending message as: bo2qSbvH to: MgqsgbDo + Over: 127.0.0.1:4242 + Message: NIntroduceClient (String:"bo2qSbvH") (String:"4444") (TName (Bool:False) (String:"SendInt")) +Sending message as: bo2qSbvH to: MgqsgbDo + Over: 127.0.0.1:4242 + Message: NNewValue (String:"bo2qSbvH") (Int:1) (VInt (Int:1)) +Recieved message as: MgqsgbDo (4242) from: bo2qSbvH + Message: NConversationMessage (String:"ElCjez4i") (NNewValue (String:"bo2qSbvH") (Int:1) (VInt (Int:1))) +Message okay: NNewValue (String:"bo2qSbvH") (Int:1) (VInt (Int:1)) +Sending message as: bo2qSbvH to: MgqsgbDo + Over: 127.0.0.1:4242 + Message: NNewValue (String:"bo2qSbvH") (Int:2) (VInt (Int:42)) +Recieved message as: MgqsgbDo (4242) from: bo2qSbvH + Message: NConversationMessage (String:"qyLarnhF") (NNewValue (String:"bo2qSbvH") (Int:2) (VInt (Int:42))) +Message okay: NNewValue (String:"bo2qSbvH") (Int:2) (VInt (Int:42)) +Recieved Message: NConversationCloseAll +Result: VUnit +Trying to connect to: 127.0.0.1:4242 +Recieved message from unknown connection! + Response to II8HNwke: NOkayIntroduce (String:"4DEOshlP") + Message: NConversationMessage (String:"pfCo4U1v") (NIntroduceClient (String:"II8HNwke") (String:"4343") (TName (Bool:True) (String:"SendSendOneInt"))) +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 +Set RedirectRequest for bo2qSbvH to 127.0.0.1:4343 + Message: NIntroduceClient (String:"II8HNwke") (String:"4343") (TName (Bool:True) (String:"SendSendOneInt")) +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Trying to connect to: 127.0.0.1:4343 +Recieved message as: II8HNwke (4343) from: 4DEOshlP +Sending message as: MgqsgbDo to: bo2qSbvH + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"MgqsgbDo") (String:"4343") +Trying to connect to: 127.0.0.1:4444 +Sending message as: MgqsgbDo to: bo2qSbvH + Over: 127.0.0.1:4444 + Message: NRequestSync (String:"MgqsgbDo") +Error when recieving response +Error when recieving response +Not connected to peer +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Original message: NIntroduceNewPartnerAddress (String:"MgqsgbDo") (String:"4343") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"XSC1nLc3") (NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444"))))) +Trying to connect to: 127.0.0.1:4444 +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Recieved message as: II8HNwke (4343) from: 4DEOshlP +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Error when recieving response +Not connected to peer +Recieved message as: 4DEOshlP (4242) from: II8HNwke +Original message: NRequestSync (String:"MgqsgbDo") +Old communication partner offline! No longer retrying +Set RedirectRequest for bo2qSbvH to 127.0.0.1:4242 +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) + Message: NConversationMessage (String:"EytF478y") (NRequestSync (String:"II8HNwke")) +Recieved message as: 4DEOshlP (4242) from: II8HNwke +Sending message as: MgqsgbDo to: bo2qSbvH + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"MgqsgbDo") (String:"4242") +Trying to connect to: 127.0.0.1:4444 +Message okay: NRequestSync (String:"II8HNwke") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))]) +Sending message as: MgqsgbDo to: bo2qSbvH + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"MgqsgbDo") (String:"4343") +Trying to connect to: 127.0.0.1:4444 +Error when recieving response +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"MgqsgbDo") (String:"4242") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"xQMFBk2S") (NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444"))))) +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"MgqsgbDo") (String:"4343") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"0uWSB08g") (NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Recieved message as: II8HNwke (4343) from: 4DEOshlP +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Recieved message as: 4DEOshlP (4242) from: II8HNwke + Message: NConversationMessage (String:"5KkHQbVf") (NRequestSync (String:"II8HNwke")) +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Recieved message as: 4DEOshlP (4242) from: II8HNwke +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") +Message okay: NRequestSync (String:"II8HNwke") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))]) +Sending message as: MgqsgbDo to: bo2qSbvH + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"MgqsgbDo") (String:"4343") +Trying to connect to: 127.0.0.1:4444 +Error when recieving response +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"MgqsgbDo") (String:"4343") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"BG8Fy8wg") (NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444"))))) +Recieved message as: II8HNwke (4343) from: 4DEOshlP + Message: NConversationMessage (String:"VUSCO9cb") (NRequestSync (String:"4DEOshlP")) +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Recieved message as: II8HNwke (4343) from: 4DEOshlP +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NRequestSync (String:"II8HNwke") +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NRequestSync (String:"II8HNwke") +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NRequestSync (String:"II8HNwke") +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NRequestSync (String:"II8HNwke") +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NRequestSync (String:"II8HNwke") +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NRequestSync (String:"II8HNwke") +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NRequestSync (String:"II8HNwke") +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NRequestSync (String:"II8HNwke") +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NRequestSync (String:"II8HNwke") +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NRequestSync (String:"II8HNwke") +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Sending message as: 4DEOshlP to: II8HNwke +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Error when recieving response +Original message: NRequestSync (String:"II8HNwke") +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NRequestSync (String:"II8HNwke") +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NRequestSync (String:"II8HNwke") +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NRequestSync (String:"II8HNwke") +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NRequestSync (String:"II8HNwke") +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NRequestSync (String:"II8HNwke") +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NRequestSync (String:"II8HNwke") +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NRequestSync (String:"II8HNwke") +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NRequestSync (String:"II8HNwke") +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"II8HNwke") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"4DEOshlP") +Sending message as: 4DEOshlP to: II8HNwke + Over: 127.0.0.1:4343 + Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Sending message as: II8HNwke to: 4DEOshlP + Over: 127.0.0.1:4242 + Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NRequestSync (String:"II8HNwke") +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Original message: NRequestSync (String:"4DEOshlP") +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +^C[laeuferle@workbench ldgvnetworking]$ \ No newline at end of file diff --git a/FastNetworkingBug3.log b/FastNetworkingBug3.log new file mode 100644 index 0000000..78969f9 --- /dev/null +++ b/FastNetworkingBug3.log @@ -0,0 +1,706 @@ +3 Handoff4 +subtype: Entering [(c, (0, SendInt))] (Nat) (Int) +subtype: Entering [(x, (0, !Int. ())), (c, (0, SendInt))] (Nat) (Int) +subtype: Entering [ (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (SendOneInt) +subtype: Entering [ (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) +subtype: Entering [ (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (SendOneInt) (SendOneInt) +subtype: Entering [ (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (SendOneInt) (?Int. ()) +subtype: Entering [ (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (?Int. ()) (?Int. ()) +subtype: Entering [ (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (Int) (Int) +subtype: [ (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz5, (_, Int)) +, (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (()) (()) +subtype: Entering [(main, (_, ()))] (()) (()) +Trying to connect to: 127.0.0.1:4242 +subtype: [ (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz5, (_, Int)) +, (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +subtype: Entering [ (z, (_, ())) +, (n, (_, Int)) +, (x, (_, ())) +, (oneint, (0, SendOneInt)) +, (y, (0, ?SendOneInt. ())) +, (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (z, (_, ())) +, (n, (_, Int)) +, (x, (_, ())) +, (oneint, (0, SendOneInt)) +, (y, (0, ?SendOneInt. ())) +, (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (~SendInt) (~SendInt) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (~SendInt) (?Int. ?Int. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ?Int. ()) (?Int. ?Int. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz6, (_, Int)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) +subtype: Entering [ (zz6, (_, Int)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (zz6, (_, Int)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz7, (_, Int)) +, (zz6, (_, Int)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendSendOneInt) (SendSendOneInt) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendSendOneInt) (!SendOneInt. ?SendOneInt. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (!SendOneInt. ?SendOneInt. ()) (!SendOneInt. ?SendOneInt. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (?Int. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz6, (_, Int)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +subtype: [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) = Kssn +subtype: [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (?Int. ()) = Kssn +subtype: [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) = Kssn +subtype: Entering [(c, (0, SendInt))] (Nat) (Int) +subtype: Entering [(x, (0, !Int. ())), (c, (0, SendInt))] (Nat) (Int) +subtype: Entering [ (c3, (_, ())) +, (n, (_, Int)) +, (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (c3, (_, ())) +, (n, (_, Int)) +, (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendInt) (SendInt) +subtype: Entering [ (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendInt) (!Int. !Int. ()) +subtype: Entering [ (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (!Int. !Int. ()) (!Int. !Int. ()) +subtype: Entering [ (zz6, (0, SendOneInt)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (?SendOneInt. ()) (?SendOneInt. ()) +subtype: Entering [ (zz6, (0, SendOneInt)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) +subtype: [ (zz6, (0, SendOneInt)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) = Kssn +subtype: Entering [ (zz7, (0, SendOneInt)) +, (zz6, (0, SendOneInt)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +subtype: Entering [ (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz5, (_, Int)) +, (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (!Int. ()) (!Int. ()) +subtype: Entering [ (zz5, (_, Int)) +, (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (zz5, (_, Int)) +, (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz6, (_, Int)) +, (zz5, (_, Int)) +, (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +subtype: Entering [ (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +Trying to connect to: 127.0.0.1:4242 +Recieved message from unknown connection! + Response to 0ndWisfS: NOkayIntroduce (String:"opqi5Mt5") + Message: NConversationMessage (String:"7JR0O8T1") (NIntroduceClient (String:"0ndWisfS") (String:"4444") (TName (Bool:False) (String:"SendInt"))) +Sending message as: 0ndWisfS to: opqi5Mt5 + Over: 127.0.0.1:4242 + Message: NIntroduceClient (String:"0ndWisfS") (String:"4444") (TName (Bool:False) (String:"SendInt")) +Sending message as: 0ndWisfS to: opqi5Mt5 + Over: 127.0.0.1:4242 + Message: NNewValue (String:"0ndWisfS") (Int:1) (VInt (Int:1)) +Recieved message as: opqi5Mt5 (4242) from: 0ndWisfS + NConversationMessage (String:"HinA5wEN") (NNewValue (String:"0ndWisfS") (Int:1) (VInt (Int:1))) + Message: NConversationMessage (String:"HinA5wEN") (NNewValue (String:"0ndWisfS") (Int:1) (VInt (Int:1))) +Message okay: NNewValue (String:"0ndWisfS") (Int:1) (VInt (Int:1)) +Sending message as: 0ndWisfS to: opqi5Mt5 + Over: 127.0.0.1:4242 + Message: NNewValue (String:"0ndWisfS") (Int:2) (VInt (Int:42)) +Recieved message as: opqi5Mt5 (4242) from: 0ndWisfS + NConversationMessage (String:"e7EWU6Zb") (NNewValue (String:"0ndWisfS") (Int:2) (VInt (Int:42))) + Message: NConversationMessage (String:"e7EWU6Zb") (NNewValue (String:"0ndWisfS") (Int:2) (VInt (Int:42))) +Message okay: NNewValue (String:"0ndWisfS") (Int:2) (VInt (Int:42)) +Recieved Message: NConversationCloseAll +Result: VUnit +Trying to connect to: 127.0.0.1:4242 +Recieved message from unknown connection! + Response to z5qkcWm6: NOkayIntroduce (String:"v7pDHZIA") + Message: NConversationMessage (String:"8KfepN3p") (NIntroduceClient (String:"z5qkcWm6") (String:"4343") (TName (Bool:True) (String:"SendSendOneInt"))) +Set RedirectRequest for 0ndWisfS to 127.0.0.1:4343 +Sending message as: z5qkcWm6 to: v7pDHZIA + Over: 127.0.0.1:4242 +Sending message as: v7pDHZIA to: z5qkcWm6 + Message: NIntroduceClient (String:"z5qkcWm6") (String:"4343") (TName (Bool:True) (String:"SendSendOneInt")) + Over: 127.0.0.1:4343 + Message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Trying to connect to: 127.0.0.1:4343 +Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA + NConversationMessage (String:"mqimYCbH") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: opqi5Mt5 to: 0ndWisfS + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") +Trying to connect to: 127.0.0.1:4444 +Sending message as: opqi5Mt5 to: 0ndWisfS + Over: 127.0.0.1:4444 + Message: NRequestSync (String:"opqi5Mt5") +Error when recieving response +Original message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Not connected to peer +Trying to connect to: 127.0.0.1:4444 +Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"mqimYCbH") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: v7pDHZIA to: z5qkcWm6 + Over: 127.0.0.1:4343 + Message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA + NConversationMessage (String:"b89uRIAt") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: z5qkcWm6 to: v7pDHZIA + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"z5qkcWm6") +Error when recieving response +Not connected to peer +Original message: NRequestSync (String:"opqi5Mt5") +Old communication partner offline! No longer retrying +Set RedirectRequest for 0ndWisfS to 127.0.0.1:4242 +Sending message as: z5qkcWm6 to: v7pDHZIA + Over: 127.0.0.1:4242 + Message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 + NConversationMessage (String:"VgenmU3j") (NRequestSync (String:"z5qkcWm6")) + Message: NConversationMessage (String:"VgenmU3j") (NRequestSync (String:"z5qkcWm6")) +Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 + NConversationMessage (String:"wDvD3Uey") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: opqi5Mt5 to: 0ndWisfS + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") +Trying to connect to: 127.0.0.1:4444 +Message okay: NRequestSync (String:"z5qkcWm6") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) +Sending message as: opqi5Mt5 to: 0ndWisfS + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") +Trying to connect to: 127.0.0.1:4444 +Error when recieving response +Original message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Original message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"wDvD3Uey") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"b89uRIAt") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: v7pDHZIA to: z5qkcWm6 + Over: 127.0.0.1:4343 + Message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA + NConversationMessage (String:"gkALmpIw") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: z5qkcWm6 to: v7pDHZIA + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"z5qkcWm6") +Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 + NConversationMessage (String:"rtEunpy5") (NRequestSync (String:"z5qkcWm6")) + Message: NConversationMessage (String:"rtEunpy5") (NRequestSync (String:"z5qkcWm6")) +Message okay: NRequestSync (String:"z5qkcWm6") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) +Sending message as: opqi5Mt5 to: 0ndWisfS + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") +Trying to connect to: 127.0.0.1:4444 +Sending message as: z5qkcWm6 to: v7pDHZIA + Over: 127.0.0.1:4242 + Message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"gkALmpIw") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 + NConversationMessage (String:"OShDQea8") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: v7pDHZIA to: z5qkcWm6 + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"v7pDHZIA") +Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA + NConversationMessage (String:"EOBR51VZ") (NRequestSync (String:"v7pDHZIA")) + Message: NConversationMessage (String:"EOBR51VZ") (NRequestSync (String:"v7pDHZIA")) +Message okay: NRequestSync (String:"v7pDHZIA") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) +Sending message as: opqi5Mt5 to: 0ndWisfS + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") +Trying to connect to: 127.0.0.1:4444 +Sending message as: v7pDHZIA to: z5qkcWm6 + Over: 127.0.0.1:4343 + Message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"OShDQea8") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA + NConversationMessage (String:"czKQA1XT") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: z5qkcWm6 to: v7pDHZIA + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"z5qkcWm6") +Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 + NConversationMessage (String:"VQX9jXAK") (NRequestSync (String:"z5qkcWm6")) + Message: NConversationMessage (String:"VQX9jXAK") (NRequestSync (String:"z5qkcWm6")) +Message okay: NRequestSync (String:"z5qkcWm6") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) +Sending message as: opqi5Mt5 to: 0ndWisfS + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") +Trying to connect to: 127.0.0.1:4444 +Sending message as: z5qkcWm6 to: v7pDHZIA + Over: 127.0.0.1:4242 + Message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"czKQA1XT") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 + NConversationMessage (String:"9gBvfDO3") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: v7pDHZIA to: z5qkcWm6 + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"v7pDHZIA") +Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA + NConversationMessage (String:"BbHUwwOB") (NRequestSync (String:"v7pDHZIA")) + Message: NConversationMessage (String:"BbHUwwOB") (NRequestSync (String:"v7pDHZIA")) +Message okay: NRequestSync (String:"v7pDHZIA") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) +Sending message as: opqi5Mt5 to: 0ndWisfS + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") +Trying to connect to: 127.0.0.1:4444 +Sending message as: v7pDHZIA to: z5qkcWm6 + Over: 127.0.0.1:4343 + Message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"9gBvfDO3") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA + NConversationMessage (String:"eB6tYctB") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: z5qkcWm6 to: v7pDHZIA + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"z5qkcWm6") +Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 + NConversationMessage (String:"z0fwWWLw") (NRequestSync (String:"z5qkcWm6")) + Message: NConversationMessage (String:"z0fwWWLw") (NRequestSync (String:"z5qkcWm6")) +Message okay: NRequestSync (String:"z5qkcWm6") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) +Sending message as: opqi5Mt5 to: 0ndWisfS + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") +Trying to connect to: 127.0.0.1:4444 +Sending message as: z5qkcWm6 to: v7pDHZIA + Over: 127.0.0.1:4242 + Message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"eB6tYctB") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 + NConversationMessage (String:"MEoNrJ5w") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: v7pDHZIA to: z5qkcWm6 + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"v7pDHZIA") +Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA + NConversationMessage (String:"efVlRDkm") (NRequestSync (String:"v7pDHZIA")) + Message: NConversationMessage (String:"efVlRDkm") (NRequestSync (String:"v7pDHZIA")) +Message okay: NRequestSync (String:"v7pDHZIA") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) +Sending message as: opqi5Mt5 to: 0ndWisfS + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") +Trying to connect to: 127.0.0.1:4444 +Sending message as: v7pDHZIA to: z5qkcWm6 + Over: 127.0.0.1:4343 + Message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"MEoNrJ5w") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA + NConversationMessage (String:"KVxqzA0Z") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: z5qkcWm6 to: v7pDHZIA + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"z5qkcWm6") +Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 + NConversationMessage (String:"7xupNmIX") (NRequestSync (String:"z5qkcWm6")) + Message: NConversationMessage (String:"7xupNmIX") (NRequestSync (String:"z5qkcWm6")) +Message okay: NRequestSync (String:"z5qkcWm6") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) +Sending message as: opqi5Mt5 to: 0ndWisfS + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") +Trying to connect to: 127.0.0.1:4444 +Sending message as: z5qkcWm6 to: v7pDHZIA + Over: 127.0.0.1:4242 + Message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"KVxqzA0Z") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 + NConversationMessage (String:"Eu2mzaCi") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: v7pDHZIA to: z5qkcWm6 + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"v7pDHZIA") +Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA + NConversationMessage (String:"iFmAfU9I") (NRequestSync (String:"v7pDHZIA")) + Message: NConversationMessage (String:"iFmAfU9I") (NRequestSync (String:"v7pDHZIA")) +Message okay: NRequestSync (String:"v7pDHZIA") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) +Sending message as: opqi5Mt5 to: 0ndWisfS + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") +Trying to connect to: 127.0.0.1:4444 +Sending message as: v7pDHZIA to: z5qkcWm6 + Over: 127.0.0.1:4343 + Message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"Eu2mzaCi") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA + NConversationMessage (String:"EHFOtFgj") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: z5qkcWm6 to: v7pDHZIA + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"z5qkcWm6") +Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 + NConversationMessage (String:"0FnB0n6H") (NRequestSync (String:"z5qkcWm6")) + Message: NConversationMessage (String:"0FnB0n6H") (NRequestSync (String:"z5qkcWm6")) +Message okay: NRequestSync (String:"z5qkcWm6") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) +Sending message as: opqi5Mt5 to: 0ndWisfS + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") +Trying to connect to: 127.0.0.1:4444 +Sending message as: z5qkcWm6 to: v7pDHZIA + Over: 127.0.0.1:4242 + Message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"EHFOtFgj") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 + NConversationMessage (String:"DOFILdDN") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: v7pDHZIA to: z5qkcWm6 + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"v7pDHZIA") +Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA + NConversationMessage (String:"PSCyb6f9") (NRequestSync (String:"v7pDHZIA")) + Message: NConversationMessage (String:"PSCyb6f9") (NRequestSync (String:"v7pDHZIA")) +Message okay: NRequestSync (String:"v7pDHZIA") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) +Sending message as: opqi5Mt5 to: 0ndWisfS + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") +Trying to connect to: 127.0.0.1:4444 +Sending message as: v7pDHZIA to: z5qkcWm6 + Over: 127.0.0.1:4343 + Message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4242 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"DOFILdDN") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA + NConversationMessage (String:"59Jae5tu") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: z5qkcWm6 to: v7pDHZIA + Over: 127.0.0.1:4242 + Message: NRequestSync (String:"z5qkcWm6") +Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 + NConversationMessage (String:"UhrVmx7p") (NRequestSync (String:"z5qkcWm6")) + Message: NConversationMessage (String:"UhrVmx7p") (NRequestSync (String:"z5qkcWm6")) +Message okay: NRequestSync (String:"z5qkcWm6") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) +Sending message as: opqi5Mt5 to: 0ndWisfS + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") +Trying to connect to: 127.0.0.1:4444 +Sending message as: z5qkcWm6 to: v7pDHZIA + Over: 127.0.0.1:4242 + Message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Original message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) +Old communication partner offline! New communication partner: 127.0.0.1:4343 +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"59Jae5tu") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 + NConversationMessage (String:"NsKpbM2L") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: v7pDHZIA to: z5qkcWm6 + Over: 127.0.0.1:4343 + Message: NRequestSync (String:"v7pDHZIA") +Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA + NConversationMessage (String:"BRVOj93u") (NRequestSync (String:"v7pDHZIA")) + Message: NConversationMessage (String:"BRVOj93u") (NRequestSync (String:"v7pDHZIA")) +Message okay: NRequestSync (String:"v7pDHZIA") +Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) +Sending message as: opqi5Mt5 to: 0ndWisfS + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") +Trying to connect to: 127.0.0.1:4444 +^C[laeuferle@workbench ldgvnetworking]$ \ No newline at end of file diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index af0c894..7f89e76 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -77,11 +77,11 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port Config.traceNetIO $ " Message: " ++ serializedMessage - mbycon <- NC.startConversation activeCons hostname port 10000 100 + mbycon <- NC.startConversation activeCons hostname port 10000 10 mbyresponse <- case mbycon of Just con -> do NC.sendMessage con message - potentialResponse <- NC.recieveResponse con 10000 100 + potentialResponse <- NC.recieveResponse con 10000 200 NC.endConversation con 10000 10 return potentialResponse Nothing -> return Nothing @@ -112,8 +112,8 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen Config.traceNetIO $ "Original message: " ++ serializedMessage case connectionstate of NCon.Connected newhostname newport -> if resendOnError /= 0 && Data.Maybe.isJust mbycon then do - Config.traceNetIO $ "Old communication partner offline! New communication partner: " ++ newhostname ++ ":" ++ newport - threadDelay 1000000 + Config.traceNetIO $ "Connected but no answer recieved! New communication partner: " ++ newhostname ++ ":" ++ newport + threadDelay 1500000 tryToSendNetworkMessage activeCons networkconnection newhostname newport message $ max (resendOnError-1) (-1) else Config.traceNetIO "Old communication partner offline! No longer retrying" diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index 4197682..34d58e9 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -97,7 +97,8 @@ recieveResponse conversation@(cid, handle, mvar, sem) waitTime tries = do return $ Just deserial Nothing -> do MVar.putMVar mvar responsesMap - if tries /= 0 then do + handleClosed <- hIsClosed handle + if tries /= 0 && not handleClosed then do -- Config.traceNetIO "Nothing yet retrying!" threadDelay waitTime recieveResponse conversation waitTime $ max (tries-1) (-1) else return Nothing diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index 2cb9ca6..55f5789 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -73,7 +73,7 @@ startConversation _ hostname port waitTime tries = do handle <- getSocketFromHandle clientsocket MVar.putMVar handleMVar handle ) $ printConErr hostname port - getFromNetworkThread threadid handleMVar waitTime tries + getFromNetworkThread Nothing threadid handleMVar waitTime tries printConErr :: String -> String -> IOException -> IO () @@ -139,17 +139,19 @@ acceptConversations ac connectionhandler port socketsmvar = do -getFromNetworkThread :: ThreadId -> MVar.MVar a -> Int -> Int -> IO (Maybe a) -getFromNetworkThread = getFromNetworkThreadWithModification Just +getFromNetworkThread :: Maybe Handle -> ThreadId -> MVar.MVar a -> Int -> Int -> IO (Maybe a) +getFromNetworkThread handle = getFromNetworkThreadWithModification handle Just -getFromNetworkThreadWithModification :: (a -> Maybe b) -> ThreadId -> MVar a -> Int -> Int -> IO (Maybe b) -getFromNetworkThreadWithModification func threadid mvar waitTime currentTry = do +getFromNetworkThreadWithModification :: Maybe Handle -> (a -> Maybe b) -> ThreadId -> MVar a -> Int -> Int -> IO (Maybe b) +getFromNetworkThreadWithModification handle func threadid mvar waitTime currentTry = do mbyResult <- MVar.tryReadMVar mvar case mbyResult of - Just handle -> return $ func handle - Nothing -> if currentTry /= 0 then do - threadDelay waitTime - getFromNetworkThreadWithModification func threadid mvar waitTime $ max (currentTry-1) (-1) + Just result -> return $ func result + Nothing -> do + handleClosed <- Data.Maybe.maybe (return False) hIsClosed handle + if currentTry /= 0 && not handleClosed then do + threadDelay waitTime + getFromNetworkThreadWithModification handle func threadid mvar waitTime $ max (currentTry-1) (-1) else do killThread threadid return Nothing @@ -158,7 +160,7 @@ recieveResponse :: Handle -> Int -> Int -> IO (Maybe Responses) recieveResponse handle waitTime tries = do retVal <- MVar.newEmptyMVar threadid <- forkIO $ recieveMessageInternal handle VG.parseResponses (\_ -> MVar.putMVar retVal Nothing) (\_ des -> MVar.putMVar retVal $ Just des) - getFromNetworkThreadWithModification id threadid retVal waitTime tries + getFromNetworkThreadWithModification (Just handle) id threadid retVal waitTime tries recieveNewMessage :: Handle -> IO (Handle, String, Messages) recieveNewMessage handle = do @@ -169,7 +171,7 @@ endConversation :: Handle -> Int -> Int -> IO () endConversation handle waitTime tries = do finished <- MVar.newEmptyMVar threadid <- forkIO $ hClose handle >> MVar.putMVar finished True - _ <- getFromNetworkThread threadid finished waitTime tries + _ <- getFromNetworkThread (Just handle) threadid finished waitTime tries return () createActiveConnections :: IO ActiveConnectionsStateless diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 527ba5f..84b7202 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -51,6 +51,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria case Map.lookup userid netcon of Just networkcon -> do Config.traceNetIO $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " (" ++ ownport ++ ") from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) + Config.traceNetIO $ " "++message if redirectRequest then sendRedirect hdl netcon userid else do case deserialmessages of NewValue userid count val -> do diff --git a/testOftenHandoff4.sh b/testOftenHandoff4.sh new file mode 100644 index 0000000..e48887d --- /dev/null +++ b/testOftenHandoff4.sh @@ -0,0 +1,3 @@ +for i in {1..2000}; do + clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/client.ldgvnw & wait); +done \ No newline at end of file From f89ec63aec97d7a27b3f0d39700f525bb3c6941c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 2 Feb 2023 12:24:13 +0100 Subject: [PATCH 099/229] Removed unnecessary code --- src/Networking/Client.hs | 46 +++++++++---------------- src/Networking/DirectionalConnection.hs | 2 -- src/Networking/Messages.hs | 5 --- src/Networking/Server.hs | 33 ------------------ 4 files changed, 16 insertions(+), 70 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 7f89e76..540995f 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -47,18 +47,16 @@ sendValue activeCons networkconnection val resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port -> do - sendVChanMessages hostname port val + setRedirectRequests hostname port val valcleaned <- replaceVChan val DC.writeMessage (ncWrite networkconnection) valcleaned messagesCount <- DC.countMessages $ ncWrite networkconnection - -- catch (tryToSend networkconnection hostname port val valcleaned) $ printConErr hostname port catch (do tryToSendNetworkMessage activeCons networkconnection hostname port (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) messagesCount valcleaned) resendOnError disableVChans val ) $ printConErr hostname port NCon.Emulated -> DC.writeMessage (ncWrite networkconnection) val _ -> Config.traceNetIO "Error when sending message: This channel is disconnected" - -- MVar.putMVar (ncConnectionState networkconnection) connectionstate sendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> Messages -> Int -> IO () sendNetworkMessage activeCons networkconnection message resendOnError = do @@ -68,7 +66,6 @@ sendNetworkMessage activeCons networkconnection message resendOnError = do catch ( tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError) $ printConErr hostname port NCon.Emulated -> pure () _ -> Config.traceNetIO "Error when sending message: This channel is disconnected" - --MVar.putMVar (ncConnectionState networkconnection) connectionstate tryToSendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> String -> String -> Messages -> Int -> IO () tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError = do @@ -107,7 +104,6 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen Nothing -> do Config.traceNetIO "Error when recieving response" connectionstate <- MVar.readMVar $ ncConnectionState networkconnection - -- connectedToPeer <- MVar.readMVar connectionsuccessful when (Data.Maybe.isNothing mbycon) $ Config.traceNetIO "Not connected to peer" Config.traceNetIO $ "Original message: " ++ serializedMessage case connectionstate of @@ -126,7 +122,6 @@ printConErr hostname port err = Config.traceIO $ "Communication Partner " ++ hos initialConnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> Syntax.Type -> IO Value initialConnect activeCons mvar hostname port ownport syntype= do - -- handle <- getClientHandle hostname port mbycon <- NC.waitForConversation activeCons hostname port 10000 100 case mbycon of @@ -159,44 +154,35 @@ initialConnect activeCons mvar hostname port ownport syntype= do Config.traceNetIO "Something went wrong while connection to the server" threadDelay 1000000 initialConnect activeCons mvar hostname port ownport syntype - -- hClose handle Nothing -> do Config.traceNetIO "Couldn't connect to server. Retrying" threadDelay 1000000 initialConnect activeCons mvar hostname port ownport syntype -sendVChanMessages :: String -> String -> Value -> IO () -sendVChanMessages newhost newport input = case input of - VSend v -> sendVChanMessages newhost newport v +setRedirectRequests :: String -> String -> Value -> IO () +setRedirectRequests newhost newport input = case input of + VSend v -> setRedirectRequests newhost newport v VPair v1 v2 -> do - sendVChanMessages newhost newport v1 - sendVChanMessages newhost newport v2 - VFunc penv a b -> sendVChanMessagesPEnv newhost newport penv - VDynCast v g -> sendVChanMessages newhost newport v - VFuncCast v a b -> sendVChanMessages newhost newport v - VRec penv a b c d -> sendVChanMessagesPEnv newhost newport penv - VNewNatRec penv a b c d e f g -> sendVChanMessagesPEnv newhost newport penv + setRedirectRequests newhost newport v1 + setRedirectRequests newhost newport v2 + VFunc penv a b -> setRedirectRequestsPEnv newhost newport penv + VDynCast v g -> setRedirectRequests newhost newport v + VFuncCast v a b -> setRedirectRequests newhost newport v + VRec penv a b c d -> setRedirectRequestsPEnv newhost newport penv + VNewNatRec penv a b c d e f g -> setRedirectRequestsPEnv newhost newport penv VChan nc _ _-> do - {- - sendNetworkMessage nc (Messages.ChangePartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID nc) newhost newport) - _ <- MVar.takeMVar $ ncConnectionState nc - Config.traceNetIO $ "Set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport - MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest newhost newport-} - oldconnectionstate <- MVar.takeMVar $ ncConnectionState nc MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest (NCon.csHostname oldconnectionstate) (NCon.csPort oldconnectionstate) newhost newport - -- tempnetcon <- NCon.newNetworkConnectionAllowingMaybe (NCon.ncPartnerUserID nc) (NCon.ncOwnUserID nc) (NCon.csHostname oldconnectionstate) (NCon.csPort oldconnectionstate) - -- sendNetworkMessage tempnetcon (Messages.ChangePartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID nc) newhost newport) 5 Config.traceNetIO $ "Set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport _ -> return () where - sendVChanMessagesPEnv :: String -> String -> [(String, Value)] -> IO () - sendVChanMessagesPEnv _ _ [] = return () - sendVChanMessagesPEnv newhost newport (x:xs) = do - sendVChanMessages newhost newport $ snd x - sendVChanMessagesPEnv newhost newport xs + setRedirectRequestsPEnv :: String -> String -> [(String, Value)] -> IO () + setRedirectRequestsPEnv _ _ [] = return () + setRedirectRequestsPEnv newhost newport (x:xs) = do + setRedirectRequests newhost newport $ snd x + setRedirectRequestsPEnv newhost newport xs replaceVChan :: Value -> IO Value replaceVChan input = case input of diff --git a/src/Networking/DirectionalConnection.hs b/src/Networking/DirectionalConnection.hs index 4b0ed7b..b15d009 100644 --- a/src/Networking/DirectionalConnection.hs +++ b/src/Networking/DirectionalConnection.hs @@ -7,8 +7,6 @@ import qualified Control.Concurrent.SSem as SSem data DirectionalConnection a = DirectionalConnection { messages :: MVar [a], messagesUnreadStart :: MVar Int, messagesCount :: MVar Int, readLock :: SSem.SSem} deriving Eq --- When a channel is duplicated there are no unread messages in the new channel, only the old one - newConnection :: IO (DirectionalConnection a) newConnection = do messages <- newEmptyMVar diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs index 8fc061d..845c6e2 100644 --- a/src/Networking/Messages.hs +++ b/src/Networking/Messages.hs @@ -4,17 +4,12 @@ module Networking.Messages where import ProcessEnvironmentTypes import Syntax -import GHC.IO.Handle -import qualified Control.Concurrent.Chan as Chan -import qualified Control.Concurrent.MVar as MVar -import qualified Data.Map as Map type UserID = String type Hostname = String type Port = String type ConversationID = String --- I need to add the Port to every introduction so I can answer oder alles muss mit einem okay quitiert werden, dann kann die antwort gesendet werden data Messages = IntroduceClient UserID Port Type | NewValue UserID Int Value diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 84b7202..ad5f955 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -32,22 +32,14 @@ import qualified Control.Concurrent as MVar import qualified Networking.Client as NC import Control.Monad --- import qualified Networking.NetworkingMethod.Stateless as NetMethod import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC --- import Networking.NetworkingMethod.Stateless (acceptConversations) --- import qualified Networking.NetworkingMethod.Fast as NetMethod handleClient :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> Messages -> IO () handleClient activeCons mvar clientlist clientsocket hdl ownport message deserialmessages = do let userid = getUserID deserialmessages - -- Config.traceNetIO $ show ownport ++ " Entering redirect handler for message: "++ message netcon <- MVar.takeMVar mvar - -- Config.traceNetIO $ show ownport ++ " Entered redirect handler for message: "++ message redirectRequest <- checkRedirectRequest netcon userid - -- Config.traceNetIO $ show ownport ++ " Redirect request" ++ show redirectRequest - -- Config.traceNetIO $ show ownport ++ " Leaving redirect handler for message: " ++ message MVar.putMVar mvar netcon - -- Config.traceNetIO $ show ownport ++ " Left redirect handler for message: " ++ message case Map.lookup userid netcon of Just networkcon -> do Config.traceNetIO $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " (" ++ ownport ++ ") from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) @@ -58,13 +50,11 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria handleNewValue activeCons mvar userid count val ownport hdl IntroduceClient userid clientport syntype-> do handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype - -- Okay message is handled in handle introduce ChangePartnerAddress userid hostname port -> do handleChangePartnerAddress activeCons mvar userid hostname port ownport NC.sendResponse hdl Messages.Okay RequestSync userid -> do handleRequestSync mvar userid hdl - -- NC.sendResponse Messages.Okay hdl SyncIncoming userid values -> do handleSyncIncoming mvar userid values NC.sendResponse hdl Messages.Okay @@ -83,8 +73,6 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria _ -> return () Config.traceNetIO $ "Put MVar for message: " ++ message MVar.putMVar mvar networkconnectionmap - -- For some reason constate doesn't seem to properly apply MVar.putMVar mvar networkconnectionmap - Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that NC.sendResponse hdl Messages.Okay @@ -98,13 +86,6 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria case deserialmessages of IntroduceClient userid clientport syntype-> do handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype - -- Okay message is handled in handle introduce - {- - IntroduceNewPartnerAddress userid port -> do - -- NC.sendResponse Messages.Okay hdl - NC.sendResponse hdl Messages.Wait - -- We don't know them yet, but should know them as soon as we get the message from the former comm partner - -} _ -> do serial <- NSerialize.serialize deserialmessages Config.traceIO $ "Error unsupported networkmessage: "++ serial @@ -141,25 +122,17 @@ handleNewValue :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkCon handleNewValue activeCons mvar userid count val ownport hdl = do -- networkconnectionmap <- MVar.takeMVar mvar networkconnectionmap <- MVar.readMVar mvar - -- Config.traceNetIO $ show ownport ++ " Entered NewValue handler" case Map.lookup userid networkconnectionmap of Just networkconnection -> do ND.lockInterpreterReads (ncRead networkconnection) - -- Config.traceNetIO "ENTERED READ LOCK" - -- Config.traceNetIO $ show ownport ++ " Reading message" success <- ND.writeMessageIfNext (ncRead networkconnection) count val - -- if success then Config.traceNetIO $ show ownport ++ " Message valid" else Config.traceNetIO $ show ownport ++ " Message invalid" unless success $ NC.sendNetworkMessage activeCons networkconnection (Messages.RequestSync $ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) (-1) - -- Config.traceNetIO $ show ownport ++ " Contacting peers" contactNewPeers activeCons val ownport - -- Config.traceNetIO $ show ownport ++ " Contacted peers" NC.sendResponse hdl Messages.Okay ND.unlockInterpreterReads (ncRead networkconnection) - -- Config.traceNetIO "LEFT READ LOCK" Nothing -> do NC.sendResponse hdl Messages.Okay Config.traceNetIO "Error during recieving a networkmessage: Introduction is needed prior to sending values!" - -- Config.traceNetIO $ show ownport ++ " Leaving NewValue handler" -- MVar.putMVar mvar networkconnectionmap contactNewPeers :: NMC.ActiveConnections -> Value -> String -> IO () @@ -220,7 +193,6 @@ handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype networkconnection <- newNetworkConnection userid serverid (hostaddressTypeToString hostname) clientport let newnetworkconnectionmap = Map.insert userid networkconnection networkconnectionmap MVar.putMVar mvar newnetworkconnectionmap - -- NC.sendResponse (Introduce serverid) hdl -- Answer with own serverid NC.sendResponse hdl (Messages.OkayIntroduce serverid) repserial <- NSerialize.serialize $ Messages.OkayIntroduce serverid Config.traceNetIO $ " Response to "++ userid ++ ": " ++ repserial @@ -253,7 +225,6 @@ handleRequestSync mvar userid hdl = do Just networkconnection -> do -- Change to current network address writevals <- ND.allMessages $ ncWrite networkconnection NC.sendResponse hdl (Messages.OkaySync writevals) - -- NClient.sendNetworkMessage networkconnection (SyncIncoming (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) writevals) 5 othing -> return () handleSyncIncoming :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> [Value] -> IO () @@ -343,7 +314,3 @@ replaceVChanSerial activeCons mvar input = case input of newval <- replaceVChanSerial activeCons mvar $ snd x rest <- replaceVChanSerialPEnv activeCons mvar xs return $ (fst x, newval):rest - --- createActiveConnections = NetMethod.createActiveConnections - --- acceptConversations = NetMethod.acceptConversations From b0e6510479c252f2b13c7877543e895fe6f71520 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 2 Feb 2023 14:12:33 +0100 Subject: [PATCH 100/229] Speed and hopefully stability improvements --- {src => log}/FastNetworkingBug.log | 0 .../FastNetworkingBug2.log | 0 .../FastNetworkingBug3.log | 0 log/FastNetworkingBug4.log | 386 ++++++++++++++++++ src/Interpreter.hs | 3 +- src/Networking/Client.hs | 4 +- src/Networking/Messages.hs | 2 - src/Networking/NetworkConnection.hs | 24 +- src/Networking/Serialize.hs | 2 - src/Networking/Server.hs | 25 +- src/ValueParsing/ValueGrammar.y | 4 - src/ValueParsing/ValueTokens.x | 4 - 12 files changed, 409 insertions(+), 45 deletions(-) rename {src => log}/FastNetworkingBug.log (100%) rename FastNetworkingBug2.log => log/FastNetworkingBug2.log (100%) rename FastNetworkingBug3.log => log/FastNetworkingBug3.log (100%) create mode 100644 log/FastNetworkingBug4.log diff --git a/src/FastNetworkingBug.log b/log/FastNetworkingBug.log similarity index 100% rename from src/FastNetworkingBug.log rename to log/FastNetworkingBug.log diff --git a/FastNetworkingBug2.log b/log/FastNetworkingBug2.log similarity index 100% rename from FastNetworkingBug2.log rename to log/FastNetworkingBug2.log diff --git a/FastNetworkingBug3.log b/log/FastNetworkingBug3.log similarity index 100% rename from FastNetworkingBug3.log rename to log/FastNetworkingBug3.log diff --git a/log/FastNetworkingBug4.log b/log/FastNetworkingBug4.log new file mode 100644 index 0000000..70989fe --- /dev/null +++ b/log/FastNetworkingBug4.log @@ -0,0 +1,386 @@ +68 Handoff4 +subtype: Entering [(c, (0, SendInt))] (Nat) (Int) +subtype: Entering [(x, (0, !Int. ())), (c, (0, SendInt))] (Nat) (Int) +subtype: Entering [ (c3, (_, ())) +, (n, (_, Int)) +, (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (c3, (_, ())) +, (n, (_, Int)) +, (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendInt) (SendInt) +subtype: Entering [ (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendInt) (!Int. !Int. ()) +subtype: Entering [ (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (!Int. !Int. ()) (!Int. !Int. ()) +subtype: Entering [ (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz5, (_, Int)) +, (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (!Int. ()) (!Int. ()) +subtype: Entering [ (zz5, (_, Int)) +, (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (zz5, (_, Int)) +, (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz6, (_, Int)) +, (zz5, (_, Int)) +, (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +subtype: Entering [ (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +Trying to connect to: 127.0.0.1:4242 +subtype: Entering [(c, (0, SendInt))] (Nat) (Int) +subtype: Entering [(x, (0, !Int. ())), (c, (0, SendInt))] (Nat) (Int) +subtype: Entering [ (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (SendOneInt) +subtype: Entering [ (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) +subtype: Entering [ (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (SendOneInt) (SendOneInt) +subtype: Entering [ (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (SendOneInt) (?Int. ()) +subtype: Entering [ (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (?Int. ()) (?Int. ()) +subtype: Entering [ (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (Int) (Int) +subtype: [ (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz5, (_, Int)) +, (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (()) (()) +subtype: Entering [(main, (_, ()))] (()) (()) +Trying to connect to: 127.0.0.1:4242 +subtype: [ (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz5, (_, Int)) +, (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +subtype: Entering [ (z, (_, ())) +, (n, (_, Int)) +, (x, (_, ())) +, (oneint, (0, SendOneInt)) +, (y, (0, ?SendOneInt. ())) +, (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (z, (_, ())) +, (n, (_, Int)) +, (x, (_, ())) +, (oneint, (0, SendOneInt)) +, (y, (0, ?SendOneInt. ())) +, (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (~SendInt) (~SendInt) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (~SendInt) (?Int. ?Int. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ?Int. ()) (?Int. ?Int. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz6, (_, Int)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) +subtype: Entering [ (zz6, (_, Int)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (zz6, (_, Int)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz7, (_, Int)) +, (zz6, (_, Int)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendSendOneInt) (SendSendOneInt) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendSendOneInt) (!SendOneInt. ?SendOneInt. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (!SendOneInt. ?SendOneInt. ()) (!SendOneInt. ?SendOneInt. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (?Int. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz6, (_, Int)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +subtype: [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) = Kssn +subtype: [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (?Int. ()) = Kssn +subtype: [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) = Kssn +subtype: Entering [ (zz6, (0, SendOneInt)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (?SendOneInt. ()) (?SendOneInt. ()) +subtype: Entering [ (zz6, (0, SendOneInt)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) +subtype: [ (zz6, (0, SendOneInt)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) = Kssn +subtype: Entering [ (zz7, (0, SendOneInt)) +, (zz6, (0, SendOneInt)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +subtype: Entering [ (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +Trying to connect to: 127.0.0.1:4242 +Recieved message from unknown connection! + Response to VpPec4uW: NOkayIntroduce (String:"jH1858Qj") + Message: NConversationMessage (String:"S3CtxIOM") (NIntroduceClient (String:"VpPec4uW") (String:"4444") (TName (Bool:False) (String:"SendInt"))) +Sending message as: VpPec4uW to: jH1858Qj + Over: 127.0.0.1:4242 + Message: NIntroduceClient (String:"VpPec4uW") (String:"4444") (TName (Bool:False) (String:"SendInt")) +Sending message as: VpPec4uW to: jH1858Qj + Over: 127.0.0.1:4242 + Message: NNewValue (String:"VpPec4uW") (Int:1) (VInt (Int:1)) +Trying to connect to: 127.0.0.1:4242 +Recieved message as: jH1858Qj (4242) from: VpPec4uW + NConversationMessage (String:"4TMypj1q") (NNewValue (String:"VpPec4uW") (Int:1) (VInt (Int:1))) + Message: NConversationMessage (String:"4TMypj1q") (NNewValue (String:"VpPec4uW") (Int:1) (VInt (Int:1))) +Recieved message from unknown connection! + Response to vMZnsPjr: NOkayIntroduce (String:"UlCVAW3h") + Message: NConversationMessage (String:"BgozYUq4") (NIntroduceClient (String:"vMZnsPjr") (String:"4343") (TName (Bool:True) (String:"SendSendOneInt"))) +Message okay: NNewValue (String:"VpPec4uW") (Int:1) (VInt (Int:1)) +Sending message as: VpPec4uW to: jH1858Qj + Over: 127.0.0.1:4242 + Message: NNewValue (String:"VpPec4uW") (Int:2) (VInt (Int:42)) +Recieved message as: jH1858Qj (4242) from: VpPec4uW +Set RedirectRequest for VpPec4uW to 127.0.0.1:4343 + NConversationMessage (String:"BCDcGrTr") (NNewValue (String:"VpPec4uW") (Int:2) (VInt (Int:42))) +Sending message as: UlCVAW3h to: vMZnsPjr + Over: 127.0.0.1:4343 + Message: NConversationMessage (String:"BCDcGrTr") (NNewValue (String:"VpPec4uW") (Int:2) (VInt (Int:42))) + Message: NNewValue (String:"UlCVAW3h") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"VpPec4uW") (String:"jH1858Qj") (((String:"127.0.0.1") (String:"4444")))) +Trying to connect to: 127.0.0.1:4343 +Sending message as: vMZnsPjr to: UlCVAW3h + Over: 127.0.0.1:4242 + Message: NIntroduceClient (String:"vMZnsPjr") (String:"4343") (TName (Bool:True) (String:"SendSendOneInt")) +Message okay: NNewValue (String:"VpPec4uW") (Int:2) (VInt (Int:42)) +Recieved Message: NConversationCloseAll +Recieved message as: vMZnsPjr (4343) from: UlCVAW3h + NConversationMessage (String:"63Rah82u") (NNewValue (String:"UlCVAW3h") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"VpPec4uW") (String:"jH1858Qj") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: jH1858Qj to: VpPec4uW + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"jH1858Qj") (String:"4343") +Trying to connect to: 127.0.0.1:4444 +Result: VUnit +Sending message as: jH1858Qj to: VpPec4uW + Over: 127.0.0.1:4444 + Message: NRequestSync (String:"jH1858Qj") +Set RedirectRequest for VpPec4uW to 127.0.0.1:4242 +Sending message as: vMZnsPjr to: UlCVAW3h + Over: 127.0.0.1:4242 + Message: NConversationMessage (String:"63Rah82u") (NNewValue (String:"UlCVAW3h") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"VpPec4uW") (String:"jH1858Qj") (((String:"127.0.0.1") (String:"4444"))))) + Message: NNewValue (String:"vMZnsPjr") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"VpPec4uW") (String:"jH1858Qj") (((String:"127.0.0.1") (String:"4444")))) +Recieved message as: UlCVAW3h (4242) from: vMZnsPjr + NConversationMessage (String:"OVTL5vVl") (NNewValue (String:"vMZnsPjr") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"VpPec4uW") (String:"jH1858Qj") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: jH1858Qj to: VpPec4uW + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"jH1858Qj") (String:"4242") +Trying to connect to: 127.0.0.1:4444 +Message okay: NNewValue (String:"UlCVAW3h") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"VpPec4uW") (String:"jH1858Qj") (((String:"127.0.0.1") (String:"4444")))) +Error when recieving response +Not connected to peer +Original message: NIntroduceNewPartnerAddress (String:"jH1858Qj") (String:"4242") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"OVTL5vVl") (NNewValue (String:"vMZnsPjr") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"VpPec4uW") (String:"jH1858Qj") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: jH1858Qj to: VpPec4uW + Over: 127.0.0.1:4444 + Message: NRequestSync (String:"jH1858Qj") +Trying to connect to: 127.0.0.1:4444 +Message okay: NNewValue (String:"vMZnsPjr") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"VpPec4uW") (String:"jH1858Qj") (((String:"127.0.0.1") (String:"4444")))) +Recieved Message: NConversationCloseAll +Error: : commitBuffer: resource vanished (Broken pipe) +Error when recieving response +Not connected to peer +Original message: NRequestSync (String:"jH1858Qj") +Old communication partner offline! No longer retrying \ No newline at end of file diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 31b71dd..7e636e6 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -55,6 +55,7 @@ import qualified Control.Concurrent as MVar import qualified Control.Concurrent as MVar import qualified Control.Concurrent as MVar import qualified Control.Concurrent as MVar +import qualified Control.Concurrent.SSem as SSem -- import qualified Networking.NetworkConnection as NCon -- import qualified Networking.NetworkConnection as NCon @@ -292,7 +293,7 @@ interpretApp _ (VSend v@(VChan cc _ usedmvar)) w = do used <- liftIO $ MVar.readMVar usedmvar if used then throw $ VChanIsUsedException $ show v else do (env, (sockets, activeConnections)) <- ask - liftIO $ NClient.sendValue activeConnections cc w (-1) + liftIO $ SSem.withSem (NCon.ncHandlingIncomingMessage cc) $ NClient.sendValue activeConnections cc w (-1) -- Disable old VChan newV <- liftIO $ disableOldVChan v diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 540995f..dcc148f 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -17,19 +17,19 @@ import qualified Networking.UserID as UserID import qualified Data.Map as Map import GHC.IO.Handle import qualified Data.Maybe -import Networking.NetworkConnection (NetworkConnection(ncConnectionState, ncOwnUserID, ncRecievedRequestClose), ConnectionState (Disconnected)) +import Networking.NetworkConnection import Control.Concurrent import Control.Exception import GHC.Exception import qualified Syntax import qualified Networking.Common as NC -import Networking.Messages (Messages(RequestClose)) import qualified Networking.NetworkConnection as NCon import qualified Control.Concurrent as MVar import qualified Config import qualified Networking.Serialize as NSerialize import Control.Monad import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC +import qualified Control.Concurrent.SSem as SSem newtype ClientException = NoIntroductionException String diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs index 845c6e2..7b6fda9 100644 --- a/src/Networking/Messages.hs +++ b/src/Networking/Messages.hs @@ -17,7 +17,6 @@ data Messages | RequestSync UserID | ChangePartnerAddress UserID Hostname Port | IntroduceNewPartnerAddress UserID Port - | RequestClose UserID deriving Eq data Responses @@ -40,5 +39,4 @@ getUserID = \case SyncIncoming p _ -> p RequestSync p -> p ChangePartnerAddress p _ _ -> p - RequestClose p -> p IntroduceNewPartnerAddress p _ -> p \ No newline at end of file diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index cdb4261..58a3af9 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -3,8 +3,9 @@ module Networking.NetworkConnection where import Networking.DirectionalConnection import qualified Data.Maybe import qualified Control.Concurrent.MVar as MVar +import qualified Control.Concurrent.SSem as SSem -data NetworkConnection a = NetworkConnection {ncRead :: DirectionalConnection a, ncWrite :: DirectionalConnection a, ncPartnerUserID :: Maybe String, ncOwnUserID :: Maybe String, ncConnectionState :: MVar.MVar ConnectionState, ncRecievedRequestClose :: MVar.MVar Bool} +data NetworkConnection a = NetworkConnection {ncRead :: DirectionalConnection a, ncWrite :: DirectionalConnection a, ncPartnerUserID :: Maybe String, ncOwnUserID :: Maybe String, ncConnectionState :: MVar.MVar ConnectionState, ncHandlingIncomingMessage :: SSem.SSem} deriving Eq data ConnectionState = Connected {csHostname :: String, csPort :: String} @@ -20,9 +21,9 @@ newNetworkConnection partnerID ownID hostname port = do write <- newConnection connectionstate <- MVar.newEmptyMVar MVar.putMVar connectionstate $ Connected hostname port - reqClose <- MVar.newEmptyMVar - MVar.putMVar reqClose False - return $ NetworkConnection read write (Just partnerID) (Just ownID) connectionstate reqClose + + incomingMsg <- SSem.new 1 + return $ NetworkConnection read write (Just partnerID) (Just ownID) connectionstate incomingMsg newNetworkConnectionAllowingMaybe :: Maybe String -> Maybe String -> String -> String -> IO (NetworkConnection a) newNetworkConnectionAllowingMaybe partnerID ownID hostname port = do @@ -30,9 +31,8 @@ newNetworkConnectionAllowingMaybe partnerID ownID hostname port = do write <- newConnection connectionstate <- MVar.newEmptyMVar MVar.putMVar connectionstate $ Connected hostname port - reqClose <- MVar.newEmptyMVar - MVar.putMVar reqClose False - return $ NetworkConnection read write partnerID ownID connectionstate reqClose + incomingMsg <- SSem.new 1 + return $ NetworkConnection read write partnerID ownID connectionstate incomingMsg createNetworkConnection :: [a] -> Int -> [a] -> Int -> Maybe String -> Maybe String -> String -> String -> IO (NetworkConnection a) @@ -41,9 +41,8 @@ createNetworkConnection readList readNew writeList writeNew partnerID ownID host write <- createConnection writeList writeNew connectionstate <- MVar.newEmptyMVar MVar.putMVar connectionstate $ Connected hostname port - reqClose <- MVar.newEmptyMVar - MVar.putMVar reqClose False - return $ NetworkConnection read write partnerID ownID connectionstate reqClose + incomingMsg <- SSem.new 1 + return $ NetworkConnection read write partnerID ownID connectionstate incomingMsg createNetworkConnectionS :: ([a], Int) -> ([a], Int) -> String -> String -> (String, String) -> IO (NetworkConnection a) @@ -54,9 +53,8 @@ newEmulatedConnection :: DirectionalConnection a -> DirectionalConnection a -> I newEmulatedConnection r w = do connectionstate <- MVar.newEmptyMVar MVar.putMVar connectionstate Emulated - reqClose <- MVar.newEmptyMVar - MVar.putMVar reqClose True - return $ NetworkConnection r w Nothing Nothing connectionstate reqClose + incomingMsg <- SSem.new 1 + return $ NetworkConnection r w Nothing Nothing connectionstate incomingMsg serializeNetworkConnection :: NetworkConnection a -> IO ([a], Int, [a], Int, String, String, String, String) serializeNetworkConnection nc = do diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index da17ea2..ca9138e 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -41,7 +41,6 @@ instance Serializable Responses where serialize = \case Redirect host port -> serializeLabeledEntryMulti "NRedirect" host $ sLast port Okay -> return "NOkay" - OkayClose -> return "NOkayClose" OkayIntroduce u -> serializeLabeledEntry "NOkayIntroduce" u OkaySync vs -> serializeLabeledEntry "NOkaySync" vs Wait -> return "NWait" @@ -54,7 +53,6 @@ instance Serializable Messages where RequestSync p -> serializeLabeledEntry "NRequestSync" p ChangePartnerAddress p h port -> serializeLabeledEntryMulti "NChangePartnerAddress" p $ sNext h $ sLast port IntroduceNewPartnerAddress u p -> serializeLabeledEntryMulti "NIntroduceNewPartnerAddress" u $ sLast p - RequestClose p -> serializeLabeledEntry "NRequestClose" p instance Serializable (NCon.NetworkConnection Value) where serialize con = do diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index ad5f955..f6be123 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -33,15 +33,18 @@ import qualified Networking.Client as NC import Control.Monad import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC +import qualified Control.Concurrent.SSem as SSem handleClient :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> Messages -> IO () handleClient activeCons mvar clientlist clientsocket hdl ownport message deserialmessages = do let userid = getUserID deserialmessages - netcon <- MVar.takeMVar mvar - redirectRequest <- checkRedirectRequest netcon userid - MVar.putMVar mvar netcon + netcon <- MVar.readMVar mvar + + -- MVar.putMVar mvar netcon case Map.lookup userid netcon of - Just networkcon -> do + Just networkcon -> SSem.withSem (ncHandlingIncomingMessage networkcon) $ do + + redirectRequest <- checkRedirectRequest netcon userid Config.traceNetIO $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " (" ++ ownport ++ ") from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) Config.traceNetIO $ " "++message if redirectRequest then sendRedirect hdl netcon userid else do @@ -58,9 +61,6 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria SyncIncoming userid values -> do handleSyncIncoming mvar userid values NC.sendResponse hdl Messages.Okay - RequestClose userid -> do - handleRequestClose mvar userid - NC.sendResponse hdl Messages.Okay IntroduceNewPartnerAddress userid port -> do networkconnectionmap <- MVar.takeMVar mvar Config.traceNetIO $ "Took MVar for message: " ++ message @@ -81,6 +81,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria Config.traceIO $ "Error unsupported networkmessage: "++ serial NC.sendResponse hdl Messages.Okay Nothing -> do + redirectRequest <- checkRedirectRequest netcon userid Config.traceNetIO "Recieved message from unknown connection!" if redirectRequest then sendRedirect hdl netcon userid else do case deserialmessages of @@ -235,16 +236,6 @@ handleSyncIncoming mvar userid values = do ND.syncMessages (ncRead networkconnection) values Nothing -> return () -handleRequestClose :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> IO () -handleRequestClose mvar userid = do - networkconnectionmap <- MVar.takeMVar mvar - case Map.lookup userid networkconnectionmap of - Just networkconnection -> do - _ <- MVar.takeMVar $ ncRecievedRequestClose networkconnection - MVar.putMVar (ncRecievedRequestClose networkconnection) True - Nothing -> return () - MVar.putMVar mvar networkconnectionmap - hostaddressTypeToString :: HostAddress -> String hostaddressTypeToString hostaddress = do let (a, b, c, d) = hostAddressToTuple hostaddress diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 0bbae4e..376a97f 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -123,8 +123,6 @@ import Networking.Messages nintroducenewpartneraddress {T _ T.NIntroduceNewPartnerAddress} nredirect { T _ T.NRedirect} nokay { T _ T.NOkay} - nrequestclose { T _ T.NRequestClose } - nokayclose { T _ T.NOkayClose} nokayintroduce { T _ T.NOkayIntroduce } nokaysync { T _ T.NOkaySync } nwait { T _ T.NWait} @@ -287,11 +285,9 @@ Messages : nintroduceclient '(' String ')' '(' String ')' '(' Type ')' {Introduc | nrequestsync '(' String ')' {RequestSync $3} | nchangepartneraddress '(' String ')' '(' String ')' '(' String ')' {ChangePartnerAddress $3 $6 $9} | nintroducenewpartneraddress '(' String ')' '(' String ')' {IntroduceNewPartnerAddress $3 $6} - | nrequestclose '(' String ')' {RequestClose $3} Responses : nredirect '(' String ')' '(' String ')' {Redirect $3 $6} | nokay {Okay} - | nokayclose {OkayClose} | nokayintroduce '(' String ')' {OkayIntroduce $3} | nokaysync '(' SValuesArray ')' {OkaySync $3} | nwait {Wait} diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index 5de9fea..eb9341f 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -135,8 +135,6 @@ tokens :- "NIntroduceNewPartnerAddress" { tok $ const NIntroduceNewPartnerAddress} "NRedirect" { tok $ const NRedirect } "NOkay" { tok $ const NOkay } - "NRequestClose" { tok $ const NRequestClose } - "NOkayClose" { tok $ const NOkayClose } "NOkayIntroduce" { tok $ const NOkayIntroduce } "NOkaySync" { tok $ const NOkaySync } "NWait" { tok $ const NWait} @@ -264,8 +262,6 @@ data Token | NIntroduceNewPartnerAddress | NRedirect | NOkay - | NRequestClose - | NOkayClose | NOkayIntroduce | NOkaySync | NWait From 3b9c4c37ea70edd7aeb3151d7bd7986e16fb0e8c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 2 Feb 2023 19:40:27 +0100 Subject: [PATCH 101/229] Create FastNetworkingBug5.log --- log/FastNetworkingBug5.log | 386 +++++++++++++++++++++++++++++++++++++ 1 file changed, 386 insertions(+) create mode 100644 log/FastNetworkingBug5.log diff --git a/log/FastNetworkingBug5.log b/log/FastNetworkingBug5.log new file mode 100644 index 0000000..7783cef --- /dev/null +++ b/log/FastNetworkingBug5.log @@ -0,0 +1,386 @@ +635 Handoff4 +subtype: Entering [(c, (0, SendInt))] (Nat) (Int) +subtype: Entering [(x, (0, !Int. ())), (c, (0, SendInt))] (Nat) (Int) +subtype: Entering [ (c3, (_, ())) +, (n, (_, Int)) +, (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (c3, (_, ())) +, (n, (_, Int)) +, (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendInt) (SendInt) +subtype: Entering [ (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendInt) (!Int. !Int. ()) +subtype: Entering [ (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (!Int. !Int. ()) (!Int. !Int. ()) +subtype: Entering [ (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz5, (_, Int)) +, (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (!Int. ()) (!Int. ()) +subtype: Entering [ (zz5, (_, Int)) +, (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (zz5, (_, Int)) +, (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz6, (_, Int)) +, (zz5, (_, Int)) +, (con, (0, SendInt)) +, (sock, (_, Nat)) +, (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +subtype: Entering [ (main, (_, ())) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +Trying to connect to: 127.0.0.1:4242 +subtype: Entering [(c, (0, SendInt))] (Nat) (Int) +subtype: Entering [(x, (0, !Int. ())), (c, (0, SendInt))] (Nat) (Int) +subtype: Entering [ (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (SendOneInt) +subtype: Entering [ (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) +subtype: Entering [ (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (SendOneInt) (SendOneInt) +subtype: Entering [ (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (SendOneInt) (?Int. ()) +subtype: Entering [ (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (?Int. ()) (?Int. ()) +subtype: Entering [ (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (Int) (Int) +subtype: [ (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz5, (_, Int)) +, (c2, (0, !SendOneInt. ())) +, (oneint, (0, SendOneInt)) +, (con, (0, ~SendSendOneInt)) +, (sock, (_, Nat)) +, (main, (_, ())) ] (()) (()) +subtype: Entering [(main, (_, ()))] (()) (()) +Trying to connect to: 127.0.0.1:4242 +subtype: [ (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz5, (_, Int)) +, (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +subtype: Entering [ (z, (_, ())) +, (n, (_, Int)) +, (x, (_, ())) +, (oneint, (0, SendOneInt)) +, (y, (0, ?SendOneInt. ())) +, (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (z, (_, ())) +, (n, (_, Int)) +, (x, (_, ())) +, (oneint, (0, SendOneInt)) +, (y, (0, ?SendOneInt. ())) +, (c2, (0, ?Int. ())) +, (m, (_, Int)) +, (c3, (0, SendSendOneInt)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (~SendInt) (~SendInt) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (~SendInt) (?Int. ?Int. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ?Int. ()) (?Int. ?Int. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz6, (_, Int)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) +subtype: Entering [ (zz6, (_, Int)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (zz6, (_, Int)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz7, (_, Int)) +, (zz6, (_, Int)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendSendOneInt) (SendSendOneInt) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendSendOneInt) (!SendOneInt. ?SendOneInt. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (!SendOneInt. ?SendOneInt. ()) (!SendOneInt. ?SendOneInt. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (?Int. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) +subtype: Entering [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +subtype: [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit +subtype: Entering [ (zz6, (_, Int)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +subtype: [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) = Kssn +subtype: [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (?Int. ()) = Kssn +subtype: [ (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) = Kssn +subtype: Entering [ (zz6, (0, SendOneInt)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (?SendOneInt. ()) (?SendOneInt. ()) +subtype: Entering [ (zz6, (0, SendOneInt)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) +subtype: [ (zz6, (0, SendOneInt)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) = Kssn +subtype: Entering [ (zz7, (0, SendOneInt)) +, (zz6, (0, SendOneInt)) +, (con2, (0, SendSendOneInt)) +, (con1, (0, ~SendInt)) +, (sock, (_, Nat)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (()) (()) +subtype: Entering [ (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) +, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) +Trying to connect to: 127.0.0.1:4242 +Recieved message from unknown connection! + Response to 2qtKSkk0: NOkayIntroduce (String:"jeXkisal") + Message: NConversationMessage (String:"zX5GFXLS") (NIntroduceClient (String:"2qtKSkk0") (String:"4444") (TName (Bool:False) (String:"SendInt"))) +Trying to connect to: 127.0.0.1:4242 +Sending message as: 2qtKSkk0 to: jeXkisal + Over: 127.0.0.1:4242 + Message: NIntroduceClient (String:"2qtKSkk0") (String:"4444") (TName (Bool:False) (String:"SendInt")) +Sending message as: 2qtKSkk0 to: jeXkisal + Over: 127.0.0.1:4242 + Message: NNewValue (String:"2qtKSkk0") (Int:1) (VInt (Int:1)) +Recieved message as: jeXkisal (4242) from: 2qtKSkk0 + NConversationMessage (String:"TnqJUqNq") (NNewValue (String:"2qtKSkk0") (Int:1) (VInt (Int:1))) + Message: NConversationMessage (String:"TnqJUqNq") (NNewValue (String:"2qtKSkk0") (Int:1) (VInt (Int:1))) +Recieved message from unknown connection! + Response to wmx6A5ja: NOkayIntroduce (String:"ZiF6PJBB") + Message: NConversationMessage (String:"VfQAXOMt") (NIntroduceClient (String:"wmx6A5ja") (String:"4343") (TName (Bool:True) (String:"SendSendOneInt"))) +Message okay: NNewValue (String:"2qtKSkk0") (Int:1) (VInt (Int:1)) +Sending message as: 2qtKSkk0 to: jeXkisal + Over: 127.0.0.1:4242 + Message: NNewValue (String:"2qtKSkk0") (Int:2) (VInt (Int:42)) +Recieved message as: jeXkisal (4242) from: 2qtKSkk0 +Set RedirectRequest for 2qtKSkk0 to 127.0.0.1:4343 + NConversationMessage (String:"WTBsV5Na") (NNewValue (String:"2qtKSkk0") (Int:2) (VInt (Int:42))) + Message: NConversationMessage (String:"WTBsV5Na") (NNewValue (String:"2qtKSkk0") (Int:2) (VInt (Int:42))) +Sending message as: ZiF6PJBB to: wmx6A5ja + Over: 127.0.0.1:4343 + Message: NNewValue (String:"ZiF6PJBB") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"2qtKSkk0") (String:"jeXkisal") (((String:"127.0.0.1") (String:"4444")))) +Trying to connect to: 127.0.0.1:4343 +Sending message as: wmx6A5ja to: ZiF6PJBB + Over: 127.0.0.1:4242 + Message: NIntroduceClient (String:"wmx6A5ja") (String:"4343") (TName (Bool:True) (String:"SendSendOneInt")) +Message okay: NNewValue (String:"2qtKSkk0") (Int:2) (VInt (Int:42)) +Recieved Message: NConversationCloseAll +Recieved message as: wmx6A5ja (4343) from: ZiF6PJBB + NConversationMessage (String:"LavJod41") (NNewValue (String:"ZiF6PJBB") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"2qtKSkk0") (String:"jeXkisal") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: jeXkisal to: 2qtKSkk0 +Result: VUnit + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"jeXkisal") (String:"4343") +Trying to connect to: 127.0.0.1:4444 +Sending message as: jeXkisal to: 2qtKSkk0 + Over: 127.0.0.1:4444 + Message: NRequestSync (String:"jeXkisal") +Set RedirectRequest for 2qtKSkk0 to 127.0.0.1:4242 +Sending message as: wmx6A5ja to: ZiF6PJBB + Message: NConversationMessage (String:"LavJod41") (NNewValue (String:"ZiF6PJBB") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"2qtKSkk0") (String:"jeXkisal") (((String:"127.0.0.1") (String:"4444"))))) + Over: 127.0.0.1:4242 + Message: NNewValue (String:"wmx6A5ja") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"2qtKSkk0") (String:"jeXkisal") (((String:"127.0.0.1") (String:"4444")))) +Message okay: NNewValue (String:"ZiF6PJBB") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"2qtKSkk0") (String:"jeXkisal") (((String:"127.0.0.1") (String:"4444")))) +Recieved message as: ZiF6PJBB (4242) from: wmx6A5ja + NConversationMessage (String:"Fn1geJ94") (NNewValue (String:"wmx6A5ja") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"2qtKSkk0") (String:"jeXkisal") (((String:"127.0.0.1") (String:"4444"))))) +Sending message as: jeXkisal to: 2qtKSkk0 + Over: 127.0.0.1:4444 + Message: NIntroduceNewPartnerAddress (String:"jeXkisal") (String:"4242") +Trying to connect to: 127.0.0.1:4444 +Sending message as: jeXkisal to: 2qtKSkk0 + Over: 127.0.0.1:4444 + Message: NRequestSync (String:"jeXkisal") +Error when recieving response +Not connected to peer +Trying to connect to: 127.0.0.1:4444 +Original message: NIntroduceNewPartnerAddress (String:"jeXkisal") (String:"4242") +Old communication partner offline! No longer retrying + Message: NConversationMessage (String:"Fn1geJ94") (NNewValue (String:"wmx6A5ja") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"2qtKSkk0") (String:"jeXkisal") (((String:"127.0.0.1") (String:"4444"))))) +Message okay: NNewValue (String:"wmx6A5ja") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"2qtKSkk0") (String:"jeXkisal") (((String:"127.0.0.1") (String:"4444")))) +Recieved Message: NConversationCloseAll +Error: : commitBuffer: resource vanished (Broken pipe) +Error when recieving response +Not connected to peer +Original message: NRequestSync (String:"jeXkisal") +Old communication partner offline! No longer retrying From ed2b3e89822019a3a939043c4bd5cc1d5b709f17 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 2 Feb 2023 19:58:59 +0100 Subject: [PATCH 102/229] Simplified server code --- src/Networking/Server.hs | 45 +++++++++++++++------------------------- 1 file changed, 17 insertions(+), 28 deletions(-) diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index f6be123..90a7370 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -44,10 +44,10 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria case Map.lookup userid netcon of Just networkcon -> SSem.withSem (ncHandlingIncomingMessage networkcon) $ do - redirectRequest <- checkRedirectRequest netcon userid Config.traceNetIO $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " (" ++ ownport ++ ") from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) Config.traceNetIO $ " "++message - if redirectRequest then sendRedirect hdl netcon userid else do + redirectRequest <- checkAndSendRedirectRequest hdl netcon userid + unless redirectRequest $ case deserialmessages of NewValue userid count val -> do handleNewValue activeCons mvar userid count val ownport hdl @@ -81,43 +81,32 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria Config.traceIO $ "Error unsupported networkmessage: "++ serial NC.sendResponse hdl Messages.Okay Nothing -> do - redirectRequest <- checkRedirectRequest netcon userid Config.traceNetIO "Recieved message from unknown connection!" - if redirectRequest then sendRedirect hdl netcon userid else do - case deserialmessages of - IntroduceClient userid clientport syntype-> do - handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype - _ -> do - serial <- NSerialize.serialize deserialmessages - Config.traceIO $ "Error unsupported networkmessage: "++ serial - Config.traceIO "This is probably a timing issue! Lets resend later" - NC.sendResponse hdl Messages.Wait + case deserialmessages of + IntroduceClient userid clientport syntype-> do + handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype + _ -> do + serial <- NSerialize.serialize deserialmessages + Config.traceIO $ "Error unsupported networkmessage: "++ serial + Config.traceIO "This is probably a timing issue! Lets resend later" + NC.sendResponse hdl Messages.Wait Config.traceNetIO $ " Message: " ++ message -checkRedirectRequest :: Map.Map String (NetworkConnection Value) -> String -> IO Bool -checkRedirectRequest ncmap userid = do +checkAndSendRedirectRequest :: NC.ConversationOrHandle -> Map.Map String (NetworkConnection Value) -> String -> IO Bool +checkAndSendRedirectRequest handle ncmap userid = do case Map.lookup userid ncmap of - Nothing -> do - return False - Just networkconnection -> do - constate <- MVar.readMVar $ ncConnectionState networkconnection - case constate of - RedirectRequest {} -> return True - _ -> return False - -sendRedirect :: NC.ConversationOrHandle -> Map.Map String (NetworkConnection Value) -> String -> IO () -sendRedirect handle ncmap userid = do - case Map.lookup userid ncmap of - Nothing -> return () + Nothing -> return False Just networkconnection -> do constate <- MVar.readMVar $ ncConnectionState networkconnection case constate of RedirectRequest _ _ host port -> do + Config.traceNetIO $ "Found redirect request for: " ++ userid Config.traceNetIO $ "Send redirect to:" ++ host ++ ":" ++ port - NC.sendResponse handle (Messages.Redirect host port) - _ -> return () + NC.sendResponse handle (Messages.Redirect host port) + return True + _ -> return False handleNewValue :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> Int -> Value -> String -> NC.ConversationOrHandle -> IO () handleNewValue activeCons mvar userid count val ownport hdl = do From 0bed1cad4c908f00ac70994b41356b593511778b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 2 Feb 2023 20:14:58 +0100 Subject: [PATCH 103/229] I think I fuxed the logic bug, that caused Handoff4 to fail sometimes --- src/Interpreter.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 7e636e6..91a6012 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -293,7 +293,17 @@ interpretApp _ (VSend v@(VChan cc _ usedmvar)) w = do used <- liftIO $ MVar.readMVar usedmvar if used then throw $ VChanIsUsedException $ show v else do (env, (sockets, activeConnections)) <- ask - liftIO $ SSem.withSem (NCon.ncHandlingIncomingMessage cc) $ NClient.sendValue activeConnections cc w (-1) + + -- This needs to be modified to look for VChans also in subtypes + case w of + VChan nc _ _ -> liftIO $ SSem.wait (NCon.ncHandlingIncomingMessage nc) + _ -> return () + + liftIO $ NClient.sendValue activeConnections cc w (-1) + + case w of + VChan nc _ _ -> liftIO $ SSem.signal (NCon.ncHandlingIncomingMessage nc) + _ -> return () -- Disable old VChan newV <- liftIO $ disableOldVChan v From bdb52cf535b7de623a4ab998c03ed6898a46a1a8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 2 Feb 2023 21:29:56 +0100 Subject: [PATCH 104/229] Fixed a crash triggered when notifying peers of shutdown --- src/Networking/NetworkingMethod/Fast.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index 34d58e9..56aeec5 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -224,12 +224,14 @@ sayGoodbye activeCons = do runAll sayGoodbyeConnection connections where sayGoodbyeConnection :: Connection -> IO () - sayGoodbyeConnection connection@(handle, isClosed, messages, responses, sem) = do - handleClosed <- MVar.readMVar isClosed - unless handleClosed $ SSem.withSem sem $ Stateless.sendMessage handle ConversationCloseAll - unless handleClosed $ SSem.withSem sem $ hPutStr handle " " - hFlushAll handle - forkIO $ catch (hClose handle) onException + sayGoodbyeConnection connection@(handle, isClosed, messages, responses, sem) = do + forkIO $ catch (do + handleClosed <- MVar.readMVar isClosed + unless handleClosed $ SSem.withSem sem $ Stateless.sendMessage handle ConversationCloseAll + unless handleClosed $ SSem.withSem sem $ hPutStr handle " " + hFlushAll handle + hClose handle + ) onException return () runAll _ [] = return () runAll f (x:xs) = do From 20c990e071edf5a0e40b55537254f7b3a4d3f727 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 2 Feb 2023 23:39:43 +0100 Subject: [PATCH 105/229] Create testNWCountHigh.sh --- testNWCountHigh.sh | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 testNWCountHigh.sh diff --git a/testNWCountHigh.sh b/testNWCountHigh.sh new file mode 100644 index 0000000..cc815c8 --- /dev/null +++ b/testNWCountHigh.sh @@ -0,0 +1,10 @@ +for i in {1..20000}; do + clear; echo "$i Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/add/server.ldgvnw & stack run ldgv -- interpret < dev-examples/add/client.ldgvnw & wait); + clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/simple/server.ldgvnw & stack run ldgv -- interpret < dev-examples/simple/client.ldgvnw & wait); + clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirectional/client.ldgvnw & wait); + clear; echo "$i Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff/client.ldgvnw & wait); + clear; echo "$i Handoff2"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/client.ldgvnw & wait); + clear; echo "$i Handoff3"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff3/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/client.ldgvnw & wait); + clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/client.ldgvnw & wait); + clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/client.ldgvnw & wait); +done \ No newline at end of file From e762d0e3eb023fd4923f972e2bb86878e0b51633 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Fri, 3 Feb 2023 14:02:44 +0100 Subject: [PATCH 106/229] Improved stability When messages can be recieved and when not is now better managed --- src/Interpreter.hs | 8 ++--- src/Networking/Client.hs | 7 ++-- src/Networking/Server.hs | 77 +++++++++++++++++++++------------------- 3 files changed, 50 insertions(+), 42 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 91a6012..47d7b87 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -295,15 +295,15 @@ interpretApp _ (VSend v@(VChan cc _ usedmvar)) w = do (env, (sockets, activeConnections)) <- ask -- This needs to be modified to look for VChans also in subtypes - case w of + {- case w of VChan nc _ _ -> liftIO $ SSem.wait (NCon.ncHandlingIncomingMessage nc) - _ -> return () + _ -> return ()-} liftIO $ NClient.sendValue activeConnections cc w (-1) - case w of + {-case w of VChan nc _ _ -> liftIO $ SSem.signal (NCon.ncHandlingIncomingMessage nc) - _ -> return () + _ -> return ()-} -- Disable old VChan newV <- liftIO $ disableOldVChan v diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index dcc148f..ed71c00 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -172,9 +172,12 @@ setRedirectRequests newhost newport input = case input of VRec penv a b c d -> setRedirectRequestsPEnv newhost newport penv VNewNatRec penv a b c d e f g -> setRedirectRequestsPEnv newhost newport penv VChan nc _ _-> do + Config.traceNetIO $ "Trying to set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport - oldconnectionstate <- MVar.takeMVar $ ncConnectionState nc - MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest (NCon.csHostname oldconnectionstate) (NCon.csPort oldconnectionstate) newhost newport + SSem.withSem (ncHandlingIncomingMessage nc) (do + oldconnectionstate <- MVar.takeMVar $ ncConnectionState nc + MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest (NCon.csHostname oldconnectionstate) (NCon.csPort oldconnectionstate) newhost newport + ) Config.traceNetIO $ "Set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport _ -> return () where diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 90a7370..8e54d68 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -42,44 +42,49 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria -- MVar.putMVar mvar netcon case Map.lookup userid netcon of - Just networkcon -> SSem.withSem (ncHandlingIncomingMessage networkcon) $ do - + Just networkcon -> do -- SSem.withSem (ncHandlingIncomingMessage networkcon) $ do Config.traceNetIO $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " (" ++ ownport ++ ") from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) Config.traceNetIO $ " "++message - redirectRequest <- checkAndSendRedirectRequest hdl netcon userid - unless redirectRequest $ - case deserialmessages of - NewValue userid count val -> do - handleNewValue activeCons mvar userid count val ownport hdl - IntroduceClient userid clientport syntype-> do - handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype - ChangePartnerAddress userid hostname port -> do - handleChangePartnerAddress activeCons mvar userid hostname port ownport - NC.sendResponse hdl Messages.Okay - RequestSync userid -> do - handleRequestSync mvar userid hdl - SyncIncoming userid values -> do - handleSyncIncoming mvar userid values - NC.sendResponse hdl Messages.Okay - IntroduceNewPartnerAddress userid port -> do - networkconnectionmap <- MVar.takeMVar mvar - Config.traceNetIO $ "Took MVar for message: " ++ message - case Map.lookup userid networkconnectionmap of - Just networkconnection -> do -- Change to current network address - case snd clientsocket of - SockAddrInet _ hostname -> do - Config.traceNetIO $ "Trying to change the address to: " ++ hostaddressTypeToString hostname ++ ":" ++ port - NCon.changePartnerAddress networkconnection (hostaddressTypeToString hostname) port - _ -> return () - Config.traceNetIO $ "Put MVar for message: " ++ message - MVar.putMVar mvar networkconnectionmap - Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that - NC.sendResponse hdl Messages.Okay - - _ -> do - serial <- NSerialize.serialize deserialmessages - Config.traceIO $ "Error unsupported networkmessage: "++ serial - NC.sendResponse hdl Messages.Okay + busy <- SSem.tryWait $ ncHandlingIncomingMessage networkcon + case busy of + Just num -> do + redirectRequest <- checkAndSendRedirectRequest hdl netcon userid + unless redirectRequest $ + case deserialmessages of + NewValue userid count val -> do + handleNewValue activeCons mvar userid count val ownport hdl + IntroduceClient userid clientport syntype-> do + handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype + ChangePartnerAddress userid hostname port -> do + handleChangePartnerAddress activeCons mvar userid hostname port ownport + NC.sendResponse hdl Messages.Okay + RequestSync userid -> do + handleRequestSync mvar userid hdl + SyncIncoming userid values -> do + handleSyncIncoming mvar userid values + NC.sendResponse hdl Messages.Okay + IntroduceNewPartnerAddress userid port -> do + networkconnectionmap <- MVar.takeMVar mvar + Config.traceNetIO $ "Took MVar for message: " ++ message + case Map.lookup userid networkconnectionmap of + Just networkconnection -> do -- Change to current network address + case snd clientsocket of + SockAddrInet _ hostname -> do + Config.traceNetIO $ "Trying to change the address to: " ++ hostaddressTypeToString hostname ++ ":" ++ port + NCon.changePartnerAddress networkconnection (hostaddressTypeToString hostname) port + _ -> return () + Config.traceNetIO $ "Put MVar for message: " ++ message + MVar.putMVar mvar networkconnectionmap + Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that + NC.sendResponse hdl Messages.Okay + _ -> do + serial <- NSerialize.serialize deserialmessages + Config.traceIO $ "Error unsupported networkmessage: "++ serial + NC.sendResponse hdl Messages.Okay + SSem.signal $ ncHandlingIncomingMessage networkcon + Nothing -> do + Config.traceNetIO "Message cannot be handled at the moment! Sending wait response" + NC.sendResponse hdl Messages.Wait Nothing -> do Config.traceNetIO "Recieved message from unknown connection!" case deserialmessages of From a91206f8bfe1f61f48641a8666f835193357a8b2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Fri, 3 Feb 2023 16:18:02 +0100 Subject: [PATCH 107/229] Experimental speedup --- src/Networking/Client.hs | 10 +++++++--- src/Networking/Common.hs | 4 +++- src/Networking/NetworkingMethod/Fast.hs | 3 ++- src/Networking/NetworkingMethod/Stateless.hs | 6 +++++- 4 files changed, 17 insertions(+), 6 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index ed71c00..b14b33e 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -78,7 +78,7 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen mbyresponse <- case mbycon of Just con -> do NC.sendMessage con message - potentialResponse <- NC.recieveResponse con 10000 200 + potentialResponse <- NC.recieveResponse con 10000 100 NC.endConversation con 10000 10 return potentialResponse Nothing -> return Nothing @@ -97,7 +97,7 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen tryToSendNetworkMessage activeCons networkconnection host port message resendOnError Wait -> do Config.traceNetIO "Communication out of sync lets wait!" - threadDelay 1000000 + threadDelay 100000 tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError _ -> Config.traceNetIO "Unknown communication error" @@ -107,7 +107,11 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen when (Data.Maybe.isNothing mbycon) $ Config.traceNetIO "Not connected to peer" Config.traceNetIO $ "Original message: " ++ serializedMessage case connectionstate of - NCon.Connected newhostname newport -> if resendOnError /= 0 && Data.Maybe.isJust mbycon then do + NCon.Connected newhostname newport -> do + isClosed <- case mbycon of + Just con -> NC.isClosed con + Nothing -> return True + if resendOnError /= 0 && not isClosed then do Config.traceNetIO $ "Connected but no answer recieved! New communication partner: " ++ newhostname ++ ":" ++ newport threadDelay 1500000 tryToSendNetworkMessage activeCons networkconnection newhostname newport message $ max (resendOnError-1) (-1) diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 9ce0aaa..2db7e9a 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -34,4 +34,6 @@ recieveResponse con waitTime tries = NetMethod.recieveResponse con waitTime trie endConversation con waitTime tries = NetMethod.endConversation con waitTime tries -sayGoodbye con = NetMethod.sayGoodbye con \ No newline at end of file +sayGoodbye con = NetMethod.sayGoodbye con + +isClosed con = NetMethod.isClosed con \ No newline at end of file diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index 56aeec5..819cd7e 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -241,4 +241,5 @@ sayGoodbye activeCons = do onException _ = return () - +isClosed :: Conversation -> IO Bool +isClosed con@(conversationid, handle, mvar, sem) = hIsClosed handle diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index 55f5789..357f260 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -189,4 +189,8 @@ getSocketFromHandle socket = do sayGoodbye :: ActiveConnectionsStateless -> IO () -sayGoodbye _ = return () \ No newline at end of file +sayGoodbye _ = return () + + +isClosed :: Handle -> IO Bool +isClosed = hIsClosed \ No newline at end of file From 8107174a2c03ec1bce70146a9789fe7e5eace6ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Fri, 3 Feb 2023 17:24:27 +0100 Subject: [PATCH 108/229] More aggressive timeout for speed --- src/Networking/Client.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index b14b33e..dd86267 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -113,7 +113,7 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen Nothing -> return True if resendOnError /= 0 && not isClosed then do Config.traceNetIO $ "Connected but no answer recieved! New communication partner: " ++ newhostname ++ ":" ++ newport - threadDelay 1500000 + threadDelay 50000 tryToSendNetworkMessage activeCons networkconnection newhostname newport message $ max (resendOnError-1) (-1) else Config.traceNetIO "Old communication partner offline! No longer retrying" From 28ceffe12117804fdede67e73db628be62edb2d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sun, 5 Feb 2023 15:11:22 +0100 Subject: [PATCH 109/229] Only sync when needed --- src/Networking/Messages.hs | 7 ++----- src/Networking/Serialize.hs | 3 +-- src/Networking/Server.hs | 18 ++++++++---------- src/ValueParsing/ValueGrammar.y | 3 +-- 4 files changed, 12 insertions(+), 19 deletions(-) diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs index 7b6fda9..336f6a4 100644 --- a/src/Networking/Messages.hs +++ b/src/Networking/Messages.hs @@ -14,15 +14,13 @@ data Messages = IntroduceClient UserID Port Type | NewValue UserID Int Value | SyncIncoming UserID [Value] - | RequestSync UserID - | ChangePartnerAddress UserID Hostname Port + | RequestSync UserID Int | IntroduceNewPartnerAddress UserID Port deriving Eq data Responses = Redirect Hostname Port | Okay - | OkayClose | OkayIntroduce UserID | OkaySync [Value] | Wait @@ -37,6 +35,5 @@ getUserID = \case IntroduceClient p _ _ -> p NewValue p _ _ -> p SyncIncoming p _ -> p - RequestSync p -> p - ChangePartnerAddress p _ _ -> p + RequestSync p _ -> p IntroduceNewPartnerAddress p _ -> p \ No newline at end of file diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index ca9138e..9f3c299 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -50,8 +50,7 @@ instance Serializable Messages where IntroduceClient p port t -> serializeLabeledEntryMulti "NIntroduceClient" p $ sNext port $ sLast t NewValue p c v -> serializeLabeledEntryMulti "NNewValue" p $ sNext c $ sLast v SyncIncoming p vs -> serializeLabeledEntryMulti "NSyncIncoming" p $ sLast vs - RequestSync p -> serializeLabeledEntry "NRequestSync" p - ChangePartnerAddress p h port -> serializeLabeledEntryMulti "NChangePartnerAddress" p $ sNext h $ sLast port + RequestSync p count -> serializeLabeledEntryMulti "NRequestSync" p $ sLast count IntroduceNewPartnerAddress u p -> serializeLabeledEntryMulti "NIntroduceNewPartnerAddress" u $ sLast p instance Serializable (NCon.NetworkConnection Value) where diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 8e54d68..0604544 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -55,11 +55,8 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria handleNewValue activeCons mvar userid count val ownport hdl IntroduceClient userid clientport syntype-> do handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype - ChangePartnerAddress userid hostname port -> do - handleChangePartnerAddress activeCons mvar userid hostname port ownport - NC.sendResponse hdl Messages.Okay - RequestSync userid -> do - handleRequestSync mvar userid hdl + RequestSync userid count -> do + handleRequestSync mvar userid count hdl SyncIncoming userid values -> do handleSyncIncoming mvar userid values NC.sendResponse hdl Messages.Okay @@ -121,7 +118,8 @@ handleNewValue activeCons mvar userid count val ownport hdl = do Just networkconnection -> do ND.lockInterpreterReads (ncRead networkconnection) success <- ND.writeMessageIfNext (ncRead networkconnection) count val - unless success $ NC.sendNetworkMessage activeCons networkconnection (Messages.RequestSync $ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) (-1) + incomingCount <- ND.countMessages (ncRead networkconnection) + unless success $ NC.sendNetworkMessage activeCons networkconnection (Messages.RequestSync (Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) incomingCount) (-1) contactNewPeers activeCons val ownport NC.sendResponse hdl Messages.Okay ND.unlockInterpreterReads (ncRead networkconnection) @@ -213,13 +211,13 @@ handleChangePartnerAddress activeCons mvar userid hostname port ownport = do Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that -handleRequestSync :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> NC.ConversationOrHandle -> IO () -handleRequestSync mvar userid hdl = do +handleRequestSync :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> Int -> NC.ConversationOrHandle -> IO () +handleRequestSync mvar userid count hdl = do networkconnectionmap <- MVar.readMVar mvar case Map.lookup userid networkconnectionmap of Just networkconnection -> do -- Change to current network address writevals <- ND.allMessages $ ncWrite networkconnection - NC.sendResponse hdl (Messages.OkaySync writevals) + if length writevals > count then NC.sendResponse hdl (Messages.OkaySync writevals) else NC.sendResponse hdl Messages.Okay othing -> return () handleSyncIncoming :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> [Value] -> IO () @@ -287,7 +285,7 @@ replaceVChanSerial activeCons mvar input = case input of networkconnection <- createNetworkConnectionS r w p o c ncmap <- MVar.takeMVar mvar MVar.putMVar mvar $ Map.insert p networkconnection ncmap - NClient.sendNetworkMessage activeCons networkconnection (RequestSync o) 5 + NClient.sendNetworkMessage activeCons networkconnection (RequestSync o $ length r) 5 used<- MVar.newEmptyMVar MVar.putMVar used False return $ VChan networkconnection mvar used diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 376a97f..6682e7f 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -282,8 +282,7 @@ GType : gunit {GUnit} Messages : nintroduceclient '(' String ')' '(' String ')' '(' Type ')' {IntroduceClient $3 $6 $9} | nnewvalue '(' String ')' '(' int ')' '(' Values ')' {NewValue $3 $6 $9} | nsyncincoming '(' String ')''(' SValuesArray ')' {SyncIncoming $3 $6} - | nrequestsync '(' String ')' {RequestSync $3} - | nchangepartneraddress '(' String ')' '(' String ')' '(' String ')' {ChangePartnerAddress $3 $6 $9} + | nrequestsync '(' String ')' '(' int ')' {RequestSync $3 $6} | nintroducenewpartneraddress '(' String ')' '(' String ')' {IntroduceNewPartnerAddress $3 $6} Responses : nredirect '(' String ')' '(' String ')' {Redirect $3 $6} From b07ff27c7228f7290386a89d0e2b8a15f4af6e5f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 6 Feb 2023 14:47:32 +0100 Subject: [PATCH 110/229] added networkchannels to interpreter environment --- src/Interpreter.hs | 46 ++++++++++---------- src/Networking/NetworkingMethod/Fast.hs | 18 ++++---- src/Networking/NetworkingMethod/Stateless.hs | 20 ++++----- src/ProcessEnvironment.hs | 2 +- src/ProcessEnvironmentTypes.hs | 4 +- 5 files changed, 45 insertions(+), 45 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 47d7b87..1ca28db 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -101,10 +101,10 @@ blame exp = throw $ CastException exp -- | interpret the "main" value in an ldgv file given over stdin interpret :: [Decl] -> IO Value interpret decls = do - sockets <- MVar.newEmptyMVar + sockets <- MVar.newMVar Map.empty + vchanconnections <- MVar.newMVar Map.empty activeConnections <- NC.createActiveConnections - MVar.putMVar sockets Map.empty - result <- R.runReaderT (interpretDecl decls) ([], (sockets, activeConnections)) + result <- R.runReaderT (interpretDecl decls) ([], (sockets, vchanconnections, activeConnections)) NC.sayGoodbye activeConnections return result @@ -161,8 +161,8 @@ eval = \case case v of VPair {} -> do C.traceIO $ "Interpreting pair cast expression: Value(" ++ show v ++ ") NFType(" ++ show nft1 ++ ") NFType(" ++ show nft2 ++ ")" - (env, (sockets, activeConnections)) <- ask - v' <- lift $ reducePairCast sockets activeConnections v (toNFPair nft1) (toNFPair nft2) + (env, (sockets, vchanconnections, activeConnections)) <- ask + v' <- lift $ reducePairCast sockets vchanconnections activeConnections v (toNFPair nft1) (toNFPair nft2) maybe (blame cast) return v' _ -> let v' = reduceCast v nft1 nft2 in maybe (blame cast) return v' Var s -> ask >>= \(env, _) -> maybe (throw $ LookupException s) (liftIO . pure) (lookup s env) @@ -206,7 +206,7 @@ eval = \case if used then throw $ VChanIsUsedException $ show v else do let dcRead = NCon.ncRead ci valunclean <- liftIO $ DC.readUnreadMessageInterpreter dcRead - (env, (sockets, activeConnections)) <- ask + (env, (sockets, vchanconnections, activeConnections)) <- ask val <- liftIO $ NS.replaceVChanSerial activeConnections mvar valunclean liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e @@ -220,20 +220,20 @@ eval = \case val <- interpret' e case val of VInt port -> do - (env, (sockets, activeConnections)) <- ask - (mvar, clientlist, ownport) <- liftIO $ NC.acceptConversations activeConnections NS.handleClient port sockets + (env, (sockets, vchanconnections, activeConnections)) <- ask + (clientlist, ownport) <- liftIO $ NC.acceptConversations activeConnections NS.handleClient port sockets vchanconnections -- newuser <- liftIO $ Chan.readChan chan liftIO $ C.traceIO "Searching for correct communicationpartner" newuser <- liftIO $ NS.findFittingClient clientlist t -- There is still an issue liftIO $ C.traceIO "Client accepted" - networkconnectionmap <- liftIO $ MVar.readMVar mvar + networkconnectionmap <- liftIO $ MVar.readMVar vchanconnections case Map.lookup newuser networkconnectionmap of Nothing -> throw $ CommunicationPartnerNotFoundException newuser Just networkconnection -> do liftIO $ C.traceIO "Client successfully accepted!" used <- liftIO MVar.newEmptyMVar liftIO $ MVar.putMVar used False - return $ VChan networkconnection mvar used + return $ VChan networkconnection vchanconnections used _ -> throw $ NotAnExpectedValueException "VInt" val Connect e0 t e1 e2-> do @@ -243,15 +243,15 @@ eval = \case val <- interpret' e0 case val of VInt port -> do - (env, (sockets, activeConnections)) <- ask - (networkconmapmvar, chan, ownport) <- liftIO $ NC.acceptConversations activeConnections NS.handleClient port sockets + (env, (sockets, vchanconnections, activeConnections)) <- ask + (chan, ownport) <- liftIO $ NC.acceptConversations activeConnections NS.handleClient port sockets vchanconnections addressVal <- interpret' e1 case addressVal of VString address -> do portVal <- interpret' e2 case portVal of VInt port -> do - liftIO $ NClient.initialConnect activeConnections networkconmapmvar address (show port) ownport t + liftIO $ NClient.initialConnect activeConnections vchanconnections address (show port) ownport t _ -> throw $ NotAnExpectedValueException "VInt" portVal _ -> throw $ NotAnExpectedValueException "VString" addressVal _ -> throw $ NotAnExpectedValueException "VInt" val @@ -292,7 +292,7 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) interpretApp _ (VSend v@(VChan cc _ usedmvar)) w = do used <- liftIO $ MVar.readMVar usedmvar if used then throw $ VChanIsUsedException $ show v else do - (env, (sockets, activeConnections)) <- ask + (env, (sockets, vchanconnections, activeConnections)) <- ask -- This needs to be modified to look for VChans also in subtypes {- case w of @@ -411,21 +411,21 @@ toNFPair :: NFType -> NFType toNFPair (NFGType (GPair)) = NFPair (FuncType [] "x" TDyn TDyn) toNFPair t = t -reducePairCast :: MVar.MVar (Map.Map Int ServerSocket) -> ActiveConnections -> Value -> NFType -> NFType -> IO (Maybe Value) -reducePairCast sockets activeConnections (VPair v w) (NFPair (FuncType penv s t1 t2)) (NFPair (FuncType penv' s' t1' t2')) = do - mv' <- reduceComponent sockets activeConnections v (penv, t1) (penv', t1') +reducePairCast :: MVar.MVar (Map.Map Int ServerSocket) -> VChanConnections -> ActiveConnections -> Value -> NFType -> NFType -> IO (Maybe Value) +reducePairCast sockets vchanconnections activeConnections (VPair v w) (NFPair (FuncType penv s t1 t2)) (NFPair (FuncType penv' s' t1' t2')) = do + mv' <- reduceComponent sockets vchanconnections activeConnections v (penv, t1) (penv', t1') case mv' of Nothing -> return Nothing Just v' -> do - mw' <- reduceComponent sockets activeConnections w ((s, v) : penv, t2) ((s', v') : penv', t2') + mw' <- reduceComponent sockets vchanconnections activeConnections w ((s, v) : penv, t2) ((s', v') : penv', t2') return $ liftM2 VPair mv' mw' where - reduceComponent :: MVar.MVar (Map.Map Int ServerSocket) -> ActiveConnections -> Value -> (PEnv, Type) -> (PEnv, Type) -> IO (Maybe Value) - reduceComponent sockets activeConnections v (penv, t) (penv', t') = do - nft <- R.runReaderT (evalType t) (penv, (sockets, activeConnections)) - nft' <- R.runReaderT (evalType t') (penv', (sockets, activeConnections)) + reduceComponent :: MVar.MVar (Map.Map Int ServerSocket) -> VChanConnections -> ActiveConnections -> Value -> (PEnv, Type) -> (PEnv, Type) -> IO (Maybe Value) + reduceComponent sockets vchanconnections activeConnections v (penv, t) (penv', t') = do + nft <- R.runReaderT (evalType t) (penv, (sockets, vchanconnections, activeConnections)) + nft' <- R.runReaderT (evalType t') (penv', (sockets, vchanconnections, activeConnections)) return $ reduceCast v nft nft' -reducePairCast _ _ _ _ _ = return Nothing +reducePairCast _ _ _ _ _ _ = return Nothing equalsType :: NFType -> GType -> Bool equalsType (NFFunc (FuncType _ _ TDyn TDyn)) (GFunc _) = True diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index 819cd7e..842c82d 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -156,8 +156,8 @@ createActiveConnections = do return activeConnections -acceptConversations :: ActiveConnectionsFast -> ConnectionHandler -> Int -> MVar.MVar (Map.Map Int ServerSocket) -> IO ServerSocket -acceptConversations ac connectionhandler port socketsmvar = do +acceptConversations :: ActiveConnectionsFast -> ConnectionHandler -> Int -> MVar.MVar (Map.Map Int ServerSocket) -> VChanConnections -> IO ServerSocket +acceptConversations ac connectionhandler port socketsmvar vchanconnections = do sockets <- MVar.takeMVar socketsmvar case Map.lookup port sockets of Just socket -> do @@ -165,15 +165,15 @@ acceptConversations ac connectionhandler port socketsmvar = do return socket Nothing -> do Config.traceIO "Creating socket!" - (mvar, clientlist) <- createServer ac connectionhandler port + clientlist <- createServer ac connectionhandler port vchanconnections Config.traceIO "Socket created" - let newsocket = (mvar, clientlist, show port) + let newsocket = (clientlist, show port) let updatedMap = Map.insert port newsocket sockets MVar.putMVar socketsmvar updatedMap return newsocket where - createServer :: ActiveConnectionsFast -> ConnectionHandler -> Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), MVar.MVar [(String, Syntax.Type)]) - createServer activeCons connectionhandler port = do + createServer :: ActiveConnectionsFast -> ConnectionHandler -> Int -> VChanConnections -> IO (MVar.MVar [(String, Syntax.Type)]) + createServer activeCons connectionhandler port vchanconnections = do -- serverid <- UserID.newRandomUserID sock <- socket AF_INET Stream 0 setSocketOption sock ReuseAddr 1 @@ -185,12 +185,10 @@ acceptConversations ac connectionhandler port socketsmvar = do addrInfo <- getAddrInfo (Just hints) Nothing $ Just $ show port bind sock $ addrAddress $ head addrInfo listen sock 1024 - mvar <- MVar.newEmptyMVar - MVar.putMVar mvar Map.empty clientlist <- MVar.newEmptyMVar MVar.putMVar clientlist [] - forkIO $ acceptClients activeCons connectionhandler mvar clientlist sock $ show port - return (mvar, clientlist) + forkIO $ acceptClients activeCons connectionhandler vchanconnections clientlist sock $ show port + return clientlist acceptClients :: ActiveConnectionsFast -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> Socket -> String -> IO () acceptClients activeCons connectionhandler mvar clientlist socket ownport = do diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index 357f260..72b8207 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -87,8 +87,8 @@ waitForConversation ac hostname port waitTime tries = do Nothing -> waitForConversation ac hostname port waitTime tries -acceptConversations :: ActiveConnectionsStateless -> ConnectionHandler -> Int -> MVar.MVar (Map.Map Int ServerSocket) -> IO ServerSocket -acceptConversations ac connectionhandler port socketsmvar = do +acceptConversations :: ActiveConnectionsStateless -> ConnectionHandler -> Int -> MVar.MVar (Map.Map Int ServerSocket) -> VChanConnections -> IO ServerSocket +acceptConversations ac connectionhandler port socketsmvar vchanconnections = do sockets <- MVar.takeMVar socketsmvar case Map.lookup port sockets of Just socket -> do @@ -96,15 +96,15 @@ acceptConversations ac connectionhandler port socketsmvar = do return socket Nothing -> do Config.traceIO "Creating socket!" - (mvar, clientlist) <- createServer ac connectionhandler port + clientlist <- createServer ac connectionhandler port vchanconnections Config.traceIO "Socket created" - let newsocket = (mvar, clientlist, show port) + let newsocket = (clientlist, show port) let updatedMap = Map.insert port newsocket sockets MVar.putMVar socketsmvar updatedMap return newsocket where - createServer :: ActiveConnectionsStateless -> ConnectionHandler -> Int -> IO (MVar.MVar (Map.Map String (NetworkConnection Value)), MVar.MVar [(String, Syntax.Type)]) - createServer activeCons connectionhandler port = do + createServer :: ActiveConnectionsStateless -> ConnectionHandler -> Int -> VChanConnections -> IO (MVar.MVar [(String, Syntax.Type)]) + createServer activeCons connectionhandler port vchanconnections = do -- serverid <- UserID.newRandomUserID sock <- socket AF_INET Stream 0 setSocketOption sock ReuseAddr 1 @@ -116,12 +116,12 @@ acceptConversations ac connectionhandler port socketsmvar = do addrInfo <- getAddrInfo (Just hints) Nothing $ Just $ show port bind sock $ addrAddress $ head addrInfo listen sock 1024 - mvar <- MVar.newEmptyMVar - MVar.putMVar mvar Map.empty + -- mvar <- MVar.newEmptyMVar + -- MVar.putMVar mvar Map.empty clientlist <- MVar.newEmptyMVar MVar.putMVar clientlist [] - forkIO $ acceptClients activeCons connectionhandler mvar clientlist sock $ show port - return (mvar, clientlist) + forkIO $ acceptClients activeCons connectionhandler vchanconnections clientlist sock $ show port + return clientlist acceptClients :: ActiveConnectionsStateless -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> Socket -> String -> IO () acceptClients activeCons connectionhandler mvar clientlist socket ownport = do Config.traceIO "Waiting for clients" diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index 11c1123..868b8f0 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -28,4 +28,4 @@ import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC -- | the interpretation monad -- type InterpretM a = T.ReaderT (PEnv, (MVar.MVar (Map.Map Int ServerSocket), MVar.MVar ActiveConnections)) IO a -type InterpretM a = T.ReaderT (PEnv, (MVar.MVar (Map.Map Int ServerSocket), NMC.ActiveConnections)) IO a \ No newline at end of file +type InterpretM a = T.ReaderT (PEnv, (MVar.MVar (Map.Map Int ServerSocket), VChanConnections, NMC.ActiveConnections)) IO a \ No newline at end of file diff --git a/src/ProcessEnvironmentTypes.hs b/src/ProcessEnvironmentTypes.hs index f82c477..1796417 100644 --- a/src/ProcessEnvironmentTypes.hs +++ b/src/ProcessEnvironmentTypes.hs @@ -40,7 +40,9 @@ instance Show FuncType where -- data NetworkAddress = NetworkAddress {hostname :: String, port :: String} -- deriving (Eq, Show) -type ServerSocket = (MVar.MVar (Map.Map String (NCon.NetworkConnection Value)), MVar.MVar [(String, Type)], String) +type ServerSocket = (MVar.MVar [(String, Type)], String) + +type VChanConnections = MVar.MVar (Map.Map String (NCon.NetworkConnection Value)) type ValueRepr = String From 467dd41a8e5d5a2dc6ca1d30d3ed7bd463a1ee9e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 6 Feb 2023 15:48:42 +0100 Subject: [PATCH 111/229] Decluttered VChan code --- src/Interpreter.hs | 12 +++++------- src/Networking/Client.hs | 8 ++++---- src/Networking/Serialize.hs | 2 +- src/Networking/Server.hs | 2 +- src/ProcessEnvironmentTypes.hs | 10 ++++------ 5 files changed, 15 insertions(+), 19 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 1ca28db..a5e3c5c 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -192,22 +192,20 @@ eval = \case w <- liftIO DC.newConnection nc1 <- liftIO $ NCon.newEmulatedConnection r w nc2 <- liftIO $ NCon.newEmulatedConnection w r - mvar <- liftIO MVar.newEmptyMVar - liftIO $ MVar.putMVar mvar Map.empty used1 <- liftIO MVar.newEmptyMVar liftIO $ MVar.putMVar used1 False used2 <- liftIO MVar.newEmptyMVar liftIO $ MVar.putMVar used2 False - return $ VPair (VChan nc1 mvar used1) $ VChan nc2 mvar used2 + return $ VPair (VChan nc1 used1) $ VChan nc2 used2 Send e -> VSend <$> interpret' e -- Apply VSend to the output of interpret' e Recv e -> do - interpret' e >>= \v@(VChan ci mvar usedmvar) -> do + interpret' e >>= \v@(VChan ci usedmvar) -> do used <- liftIO $ MVar.readMVar usedmvar if used then throw $ VChanIsUsedException $ show v else do let dcRead = NCon.ncRead ci valunclean <- liftIO $ DC.readUnreadMessageInterpreter dcRead (env, (sockets, vchanconnections, activeConnections)) <- ask - val <- liftIO $ NS.replaceVChanSerial activeConnections mvar valunclean + val <- liftIO $ NS.replaceVChanSerial activeConnections vchanconnections valunclean liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e -- Disable the old channel and get a new one @@ -233,7 +231,7 @@ eval = \case liftIO $ C.traceIO "Client successfully accepted!" used <- liftIO MVar.newEmptyMVar liftIO $ MVar.putMVar used False - return $ VChan networkconnection vchanconnections used + return $ VChan networkconnection used _ -> throw $ NotAnExpectedValueException "VInt" val Connect e0 t e1 e2-> do @@ -289,7 +287,7 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) let env' = extendEnv n1 (VInt (n-1)) (extendEnv f natrec env) R.local (Data.Bifunctor.first (const env')) (interpret' es) -- interpretApp _ (VSend v@(VChan _ c handle _ _ _)) w = do -interpretApp _ (VSend v@(VChan cc _ usedmvar)) w = do +interpretApp _ (VSend v@(VChan cc usedmvar)) w = do used <- liftIO $ MVar.readMVar usedmvar if used then throw $ VChanIsUsedException $ show v else do (env, (sockets, vchanconnections, activeConnections)) <- ask diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index dd86267..d5f10d3 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -126,7 +126,7 @@ printConErr hostname port err = Config.traceIO $ "Communication Partner " ++ hos initialConnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> Syntax.Type -> IO Value initialConnect activeCons mvar hostname port ownport syntype= do - mbycon <- NC.waitForConversation activeCons hostname port 10000 100 + mbycon <- NC.waitForConversation activeCons hostname port 1000 100 -- This should be 10000 100 in the real world, expecting just a 100ms ping in the real world might be a little aggressive. case mbycon of Just con -> do @@ -147,7 +147,7 @@ initialConnect activeCons mvar hostname port ownport syntype= do MVar.putMVar mvar newNetworkconnectionmap used <- MVar.newEmptyMVar MVar.putMVar used False - return $ VChan newConnection mvar used + return $ VChan newConnection used _ -> do introductionserial <- NSerialize.serialize introduction @@ -175,7 +175,7 @@ setRedirectRequests newhost newport input = case input of VFuncCast v a b -> setRedirectRequests newhost newport v VRec penv a b c d -> setRedirectRequestsPEnv newhost newport penv VNewNatRec penv a b c d e f g -> setRedirectRequestsPEnv newhost newport penv - VChan nc _ _-> do + VChan nc _ -> do Config.traceNetIO $ "Trying to set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport SSem.withSem (ncHandlingIncomingMessage nc) (do @@ -215,7 +215,7 @@ replaceVChan input = case input of VNewNatRec penv a b c d e f g -> do newpenv <- replaceVChanPEnv penv return $ VNewNatRec newpenv a b c d e f g - VChan nc _ _-> do + VChan nc _-> do (r, rl, w, wl, pid, oid, h, p) <- serializeNetworkConnection nc return $ VChanSerial (r, rl) (w, wl) pid oid (h, p) _ -> return input diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index 9f3c299..c62c191 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -89,7 +89,7 @@ instance Serializable Value where VNewNatRec env f n tid ty ez x es -> serializeLabeledEntryMulti "VNewNatRec" env $ sNext f $ sNext n $ sNext tid $ sNext ty $ sNext ez $ sNext x $ sLast es VServerSocket {} -> throw $ UnserializableException "VServerSocket" - VChan nc _ _-> serializeLabeledEntry "VChan" nc + VChan nc _-> serializeLabeledEntry "VChan" nc VChanSerial r w p o c -> serializeLabeledEntryMulti "VChanSerial" r $ sNext w $ sNext p $ sNext o $ sLast c instance Serializable Multiplicity where diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 0604544..a9e57c7 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -288,7 +288,7 @@ replaceVChanSerial activeCons mvar input = case input of NClient.sendNetworkMessage activeCons networkconnection (RequestSync o $ length r) 5 used<- MVar.newEmptyMVar MVar.putMVar used False - return $ VChan networkconnection mvar used + return $ VChan networkconnection used _ -> return input where replaceVChanSerialPEnv :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> [(String, Value)] -> IO [(String, Value)] diff --git a/src/ProcessEnvironmentTypes.hs b/src/ProcessEnvironmentTypes.hs index 1796417..670b0d6 100644 --- a/src/ProcessEnvironmentTypes.hs +++ b/src/ProcessEnvironmentTypes.hs @@ -53,9 +53,7 @@ data Value | VInt Int | VDouble Double | VString String - | VChan (NCon.NetworkConnection Value) (MVar.MVar (Map.Map String (NCon.NetworkConnection Value))) (MVar.MVar Bool) --Maybe a "used" mvar to notify that this vchan should no longer be used - -- This is exclusively used to add VChanSerials into the map when in the interpreter - -- This is to mark a vchan as used (true if used) + | VChan (NCon.NetworkConnection Value) (MVar.MVar Bool) --Maybe a "used" mvar to notify that this vchan should no longer be used | VChanSerial ([Value], Int) ([Value], Int) String String (String, String) | VSend Value | VPair Value Value -- pair of ids that map to two values @@ -71,18 +69,18 @@ data Value disableOldVChan :: Value -> IO Value disableOldVChan value = case value of - VChan nc mvar used -> do + VChan nc used -> do _ <- MVar.takeMVar used MVar.putMVar used True unused <- MVar.newEmptyMVar MVar.putMVar unused False - return $ VChan nc mvar unused + return $ VChan nc unused _ -> return value disableVChan :: Value -> IO () disableVChan value = case value of - VChan nc mvar _ -> do + VChan nc _ -> do mbystate <- MVar.tryTakeMVar $ NCon.ncConnectionState nc --I dont fully understand why this mvar isnt filled but lets bypass this problem case mbystate of Nothing -> MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected From 26e4650236f49e37ec4e16deec083a41f26da54d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 6 Feb 2023 16:14:01 +0100 Subject: [PATCH 112/229] Fixed tests after modifying the interpreter --- test/Utils.hs | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/test/Utils.hs b/test/Utils.hs index c901572..c2d795a 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -24,10 +24,10 @@ raiseFailure msg = do shouldInterpretTo :: [Decl] -> Value -> Expectation shouldInterpretTo givenDecls expectedValue = do - sockets <- newEmptyMVar + sockets <- newMVar Map.empty + vchanconnections <- newMVar Map.empty handles <- NC.createActiveConnections - putMVar sockets Map.empty - value <- runReaderT (interpretDecl givenDecls) ([], (sockets, handles)) + value <- runReaderT (interpretDecl givenDecls) ([], (sockets, vchanconnections, handles)) value `shouldBe` expectedValue shouldThrowCastException :: [Decl] -> Expectation @@ -36,22 +36,22 @@ shouldThrowCastException givenDecls = isCastException (CastException _) = True isCastException _ = False in do - sockets <- newEmptyMVar + sockets <- newMVar Map.empty + vchanconnections <- newMVar Map.empty handles <- NC.createActiveConnections - putMVar sockets Map.empty - runReaderT (interpretDecl givenDecls) ([], (sockets, handles)) `shouldThrow` isCastException + runReaderT (interpretDecl givenDecls) ([], (sockets, vchanconnections, handles)) `shouldThrow` isCastException shouldThrowInterpreterException :: Decl -> InterpreterException -> Expectation shouldThrowInterpreterException given except = do - sockets <- newEmptyMVar + sockets <- newMVar Map.empty + vchanconnections <- newMVar Map.empty handles <- NC.createActiveConnections - putMVar sockets Map.empty - runReaderT (interpretDecl [given]) ([], (sockets, handles)) `shouldThrow` (== except) + runReaderT (interpretDecl [given]) ([], (sockets, vchanconnections, handles)) `shouldThrow` (== except) shouldInterpretTypeTo :: Type -> NFType -> Expectation shouldInterpretTypeTo t expected = do - sockets <- newEmptyMVar + sockets <- newMVar Map.empty + vchanconnections <- newMVar Map.empty handles <- NC.createActiveConnections - putMVar sockets Map.empty - nft <- runReaderT (evalType t) ([], (sockets, handles)) + nft <- runReaderT (evalType t) ([], (sockets, vchanconnections, handles)) nft `shouldBe` expected From a9b0864de16c6df5e2a515ad9a8bd74228cba5f8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 6 Feb 2023 16:53:12 +0100 Subject: [PATCH 113/229] Moved emulated vchans closer in implementation to networked This can probably be used in the future to being able to send them like networked vchans --- src/Interpreter.hs | 15 +++++------ src/Networking/Client.hs | 27 ++++++++++++++----- src/Networking/NetworkConnection.hs | 40 +++++++++++++++++++++-------- 3 files changed, 57 insertions(+), 25 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index a5e3c5c..18841fc 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -188,14 +188,10 @@ eval = \case C.traceIO "Ran a forked operation") return VUnit New t -> do - r <- liftIO DC.newConnection - w <- liftIO DC.newConnection - nc1 <- liftIO $ NCon.newEmulatedConnection r w - nc2 <- liftIO $ NCon.newEmulatedConnection w r - used1 <- liftIO MVar.newEmptyMVar - liftIO $ MVar.putMVar used1 False - used2 <- liftIO MVar.newEmptyMVar - liftIO $ MVar.putMVar used2 False + (env, (sockets, vchanconnections, activeConnections)) <- ask + (nc1, nc2) <- liftIO $ NCon.newEmulatedConnection vchanconnections + used1 <- liftIO $ MVar.newMVar False + used2 <- liftIO $ MVar.newMVar False return $ VPair (VChan nc1 used1) $ VChan nc2 used2 Send e -> VSend <$> interpret' e -- Apply VSend to the output of interpret' e Recv e -> do @@ -297,7 +293,8 @@ interpretApp _ (VSend v@(VChan cc usedmvar)) w = do VChan nc _ _ -> liftIO $ SSem.wait (NCon.ncHandlingIncomingMessage nc) _ -> return ()-} - liftIO $ NClient.sendValue activeConnections cc w (-1) + -- liftIO $ NClient.sendValue activeConnections cc w (-1) + liftIO $ NClient.sendValueFromInterpreter vchanconnections activeConnections cc w {-case w of VChan nc _ _ -> liftIO $ SSem.signal (NCon.ncHandlingIncomingMessage nc) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index d5f10d3..f6be88b 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -42,6 +42,23 @@ instance Show ClientException where instance Exception ClientException +sendValueFromInterpreter :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> Value -> IO () +sendValueFromInterpreter vchanconsmvar activecons networkconnection val = do + connectionstate <- MVar.readMVar $ ncConnectionState networkconnection + vchancons <- MVar.readMVar vchanconsmvar + case connectionstate of + NCon.Emulated -> do + valCleaned <- replaceVChan val + DC.writeMessage (ncWrite networkconnection) valCleaned + let partnerid = Data.Maybe.fromMaybe "" $ ncPartnerUserID networkconnection + let mbypartner = Map.lookup partnerid vchancons + case mbypartner of + Just partner -> DC.writeMessage (ncRead partner) valCleaned + _ -> Config.traceNetIO "Something went wrong when sending over a emulated connection" + disableVChans val + _ -> sendValue activecons networkconnection val (-1) + + sendValue :: NMC.ActiveConnections -> NetworkConnection Value -> Value -> Int -> IO () sendValue activeCons networkconnection val resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection @@ -55,7 +72,6 @@ sendValue activeCons networkconnection val resendOnError = do tryToSendNetworkMessage activeCons networkconnection hostname port (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) messagesCount valcleaned) resendOnError disableVChans val ) $ printConErr hostname port - NCon.Emulated -> DC.writeMessage (ncWrite networkconnection) val _ -> Config.traceNetIO "Error when sending message: This channel is disconnected" sendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> Messages -> Int -> IO () @@ -64,7 +80,6 @@ sendNetworkMessage activeCons networkconnection message resendOnError = do case connectionstate of NCon.Connected hostname port -> do catch ( tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError) $ printConErr hostname port - NCon.Emulated -> pure () _ -> Config.traceNetIO "Error when sending message: This channel is disconnected" tryToSendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> String -> String -> Messages -> Int -> IO () @@ -107,7 +122,7 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen when (Data.Maybe.isNothing mbycon) $ Config.traceNetIO "Not connected to peer" Config.traceNetIO $ "Original message: " ++ serializedMessage case connectionstate of - NCon.Connected newhostname newport -> do + NCon.Connected newhostname newport -> do isClosed <- case mbycon of Just con -> NC.isClosed con Nothing -> return True @@ -149,12 +164,12 @@ initialConnect activeCons mvar hostname port ownport syntype= do MVar.putMVar used False return $ VChan newConnection used - _ -> do + _ -> do introductionserial <- NSerialize.serialize introduction Config.traceNetIO $ "Illegal answer from server: " ++ introductionserial threadDelay 1000000 initialConnect activeCons mvar hostname port ownport syntype - Nothing -> do + Nothing -> do Config.traceNetIO "Something went wrong while connection to the server" threadDelay 1000000 initialConnect activeCons mvar hostname port ownport syntype @@ -178,7 +193,7 @@ setRedirectRequests newhost newport input = case input of VChan nc _ -> do Config.traceNetIO $ "Trying to set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport - SSem.withSem (ncHandlingIncomingMessage nc) (do + SSem.withSem (ncHandlingIncomingMessage nc) (do oldconnectionstate <- MVar.takeMVar $ ncConnectionState nc MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest (NCon.csHostname oldconnectionstate) (NCon.csPort oldconnectionstate) newhost newport ) diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index 58a3af9..b04bc24 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -1,7 +1,9 @@ module Networking.NetworkConnection where import Networking.DirectionalConnection +import Networking.UserID import qualified Data.Maybe +import qualified Data.Map as Map import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.SSem as SSem @@ -19,9 +21,7 @@ newNetworkConnection :: String -> String -> String -> String -> IO (NetworkConne newNetworkConnection partnerID ownID hostname port = do read <- newConnection write <- newConnection - connectionstate <- MVar.newEmptyMVar - MVar.putMVar connectionstate $ Connected hostname port - + connectionstate <- MVar.newMVar $ Connected hostname port incomingMsg <- SSem.new 1 return $ NetworkConnection read write (Just partnerID) (Just ownID) connectionstate incomingMsg @@ -29,8 +29,7 @@ newNetworkConnectionAllowingMaybe :: Maybe String -> Maybe String -> String -> S newNetworkConnectionAllowingMaybe partnerID ownID hostname port = do read <- newConnection write <- newConnection - connectionstate <- MVar.newEmptyMVar - MVar.putMVar connectionstate $ Connected hostname port + connectionstate <- MVar.newMVar $ Connected hostname port incomingMsg <- SSem.new 1 return $ NetworkConnection read write partnerID ownID connectionstate incomingMsg @@ -39,8 +38,7 @@ createNetworkConnection :: [a] -> Int -> [a] -> Int -> Maybe String -> Maybe Str createNetworkConnection readList readNew writeList writeNew partnerID ownID hostname port = do read <- createConnection readList readNew write <- createConnection writeList writeNew - connectionstate <- MVar.newEmptyMVar - MVar.putMVar connectionstate $ Connected hostname port + connectionstate <- MVar.newMVar $ Connected hostname port incomingMsg <- SSem.new 1 return $ NetworkConnection read write partnerID ownID connectionstate incomingMsg @@ -49,12 +47,34 @@ createNetworkConnectionS :: ([a], Int) -> ([a], Int) -> String -> String -> (Str createNetworkConnectionS (readList, readNew) (writeList, writeNew) partnerID ownID (hostname, port) = createNetworkConnection readList readNew writeList writeNew (Just partnerID) (Just ownID) hostname port -newEmulatedConnection :: DirectionalConnection a -> DirectionalConnection a -> IO (NetworkConnection a) +{-newEmulatedConnection :: DirectionalConnection a -> DirectionalConnection a -> IO (NetworkConnection a) newEmulatedConnection r w = do connectionstate <- MVar.newEmptyMVar MVar.putMVar connectionstate Emulated incomingMsg <- SSem.new 1 - return $ NetworkConnection r w Nothing Nothing connectionstate incomingMsg + return $ NetworkConnection r w Nothing Nothing connectionstate incomingMsg-} + +newEmulatedConnection :: MVar.MVar (Map.Map String (NetworkConnection a)) -> IO (NetworkConnection a, NetworkConnection a) +newEmulatedConnection mvar = do + ncmap <- MVar.takeMVar mvar + read <- newConnection + write <- newConnection + read2 <- newConnection + write2 <- newConnection + connectionstate <- MVar.newMVar Emulated + connectionstate2 <- MVar.newMVar Emulated + userid <- newRandomUserID + userid2 <- newRandomUserID + incomingMsg <- SSem.new 1 + incomingMsg2 <- SSem.new 1 + let nc1 = NetworkConnection read write (Just userid2) (Just userid) connectionstate incomingMsg + let nc2 = NetworkConnection read2 write2 (Just userid) (Just userid2) connectionstate2 incomingMsg2 + let ncmap1 = Map.insert userid nc1 ncmap + let ncmap2 = Map.insert userid2 nc2 ncmap1 + MVar.putMVar mvar ncmap2 + return (nc1, nc2) + + serializeNetworkConnection :: NetworkConnection a -> IO ([a], Int, [a], Int, String, String, String, String) serializeNetworkConnection nc = do @@ -67,7 +87,7 @@ serializeNetworkConnection nc = do _ -> return ("", "") return (readList, readUnread, writeList, writeUnread, Data.Maybe.fromMaybe "" $ ncPartnerUserID nc, Data.Maybe.fromMaybe "" $ ncOwnUserID nc, address, port) -changePartnerAddress :: NetworkConnection a -> String -> String -> IO () +changePartnerAddress :: NetworkConnection a -> String -> String -> IO () changePartnerAddress con hostname port = do _ <- MVar.takeMVar $ ncConnectionState con MVar.putMVar (ncConnectionState con) $ Connected hostname port \ No newline at end of file From 6799326dfdb7e4eab56b58277087b1a04e030e75 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 6 Feb 2023 17:54:19 +0100 Subject: [PATCH 114/229] Added new test for emulated handoff - Not yet working --- dev-examples/handoff5/add.ldgvnw | 23 ++++++++++++++++++++ dev-examples/handoff5/handoff.ldgvnw | 27 +++++++++++++++++++++++ src/Interpreter.hs | 2 +- src/Networking/Client.hs | 32 +++++++++++----------------- 4 files changed, 63 insertions(+), 21 deletions(-) create mode 100644 dev-examples/handoff5/add.ldgvnw create mode 100644 dev-examples/handoff5/handoff.ldgvnw diff --git a/dev-examples/handoff5/add.ldgvnw b/dev-examples/handoff5/add.ldgvnw new file mode 100644 index 0000000..0f648b2 --- /dev/null +++ b/dev-examples/handoff5/add.ldgvnw @@ -0,0 +1,23 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit +type SendOneInt : ! ~ssn = !Int. Unit +type SendSendOneInt : ! ~ssn = !SendOneInt. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let con = (connect 4242 SendSendOneInt "127.0.0.1" 4343 ) in + let con2 = (send con) x in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val main : Int +val main = + let = (new SendInt) in + let a1 = fork (send2 a) in + add2 b diff --git a/dev-examples/handoff5/handoff.ldgvnw b/dev-examples/handoff5/handoff.ldgvnw new file mode 100644 index 0000000..096ba0b --- /dev/null +++ b/dev-examples/handoff5/handoff.ldgvnw @@ -0,0 +1,27 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit +type SendOneInt : ! ~ssn = !Int. Unit +type SendSendOneInt : ! ~ssn = !SendOneInt. Unit + +val send1 (c: SendInt) : SendOneInt = + let x = ((send c) 1) in + (x) + +val send2 (c2: SendOneInt) = + let y = ((send c2) 42) in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val main : Unit +val main = + -- let con = (create 4343) in + let con = (accept 4343 (dualof SendSendOneInt)) in + let = recv con in + send2 oneint + diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 18841fc..da10f84 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -294,7 +294,7 @@ interpretApp _ (VSend v@(VChan cc usedmvar)) w = do _ -> return ()-} -- liftIO $ NClient.sendValue activeConnections cc w (-1) - liftIO $ NClient.sendValueFromInterpreter vchanconnections activeConnections cc w + liftIO $ NClient.sendValue vchanconnections activeConnections cc w (-1) {-case w of VChan nc _ _ -> liftIO $ SSem.signal (NCon.ncHandlingIncomingMessage nc) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index f6be88b..ff001a9 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -41,26 +41,8 @@ instance Show ClientException where instance Exception ClientException - -sendValueFromInterpreter :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> Value -> IO () -sendValueFromInterpreter vchanconsmvar activecons networkconnection val = do - connectionstate <- MVar.readMVar $ ncConnectionState networkconnection - vchancons <- MVar.readMVar vchanconsmvar - case connectionstate of - NCon.Emulated -> do - valCleaned <- replaceVChan val - DC.writeMessage (ncWrite networkconnection) valCleaned - let partnerid = Data.Maybe.fromMaybe "" $ ncPartnerUserID networkconnection - let mbypartner = Map.lookup partnerid vchancons - case mbypartner of - Just partner -> DC.writeMessage (ncRead partner) valCleaned - _ -> Config.traceNetIO "Something went wrong when sending over a emulated connection" - disableVChans val - _ -> sendValue activecons networkconnection val (-1) - - -sendValue :: NMC.ActiveConnections -> NetworkConnection Value -> Value -> Int -> IO () -sendValue activeCons networkconnection val resendOnError = do +sendValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> Value -> Int -> IO () +sendValue vchanconsmvar activeCons networkconnection val resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port -> do @@ -72,6 +54,16 @@ sendValue activeCons networkconnection val resendOnError = do tryToSendNetworkMessage activeCons networkconnection hostname port (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) messagesCount valcleaned) resendOnError disableVChans val ) $ printConErr hostname port + NCon.Emulated -> do + vchancons <- MVar.readMVar vchanconsmvar + valCleaned <- replaceVChan val + DC.writeMessage (ncWrite networkconnection) valCleaned + let partnerid = Data.Maybe.fromMaybe "" $ ncPartnerUserID networkconnection + let mbypartner = Map.lookup partnerid vchancons + case mbypartner of + Just partner -> DC.writeMessage (ncRead partner) valCleaned + _ -> Config.traceNetIO "Something went wrong when sending over a emulated connection" + disableVChans val _ -> Config.traceNetIO "Error when sending message: This channel is disconnected" sendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> Messages -> Int -> IO () From 2c3a0f638348988439ce922fd98d4a35d5ef1c5f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 7 Feb 2023 10:53:03 +0100 Subject: [PATCH 115/229] More work towards allowing to send emulated channels --- src/Interpreter.hs | 9 +++-- src/Networking/Client.hs | 58 +++++++++++++++++++---------- src/Networking/NetworkConnection.hs | 4 +- 3 files changed, 46 insertions(+), 25 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index da10f84..dcaf805 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -287,22 +287,23 @@ interpretApp _ (VSend v@(VChan cc usedmvar)) w = do used <- liftIO $ MVar.readMVar usedmvar if used then throw $ VChanIsUsedException $ show v else do (env, (sockets, vchanconnections, activeConnections)) <- ask - + -- This needs to be modified to look for VChans also in subtypes {- case w of VChan nc _ _ -> liftIO $ SSem.wait (NCon.ncHandlingIncomingMessage nc) _ -> return ()-} -- liftIO $ NClient.sendValue activeConnections cc w (-1) - liftIO $ NClient.sendValue vchanconnections activeConnections cc w (-1) + socketsraw <- liftIO $ MVar.readMVar sockets + let port = show $ head $ Map.keys socketsraw + liftIO $ NClient.sendValue vchanconnections activeConnections cc w port (-1) {-case w of VChan nc _ _ -> liftIO $ SSem.signal (NCon.ncHandlingIncomingMessage nc) _ -> return ()-} -- Disable old VChan - newV <- liftIO $ disableOldVChan v - return newV + liftIO $ disableOldVChan v interpretApp e _ _ = throw $ ApplicationException e interpretLit :: Literal -> Value diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index ff001a9..94e0602 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -41,12 +41,12 @@ instance Show ClientException where instance Exception ClientException -sendValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> Value -> Int -> IO () -sendValue vchanconsmvar activeCons networkconnection val resendOnError = do +sendValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> Value -> String -> Int -> IO () +sendValue vchanconsmvar activeCons networkconnection val ownport resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port -> do - setRedirectRequests hostname port val + setRedirectRequests vchanconsmvar hostname port ownport val valcleaned <- replaceVChan val DC.writeMessage (ncWrite networkconnection) valcleaned messagesCount <- DC.countMessages $ ncWrite networkconnection @@ -171,32 +171,52 @@ initialConnect activeCons mvar hostname port ownport syntype= do initialConnect activeCons mvar hostname port ownport syntype -setRedirectRequests :: String -> String -> Value -> IO () -setRedirectRequests newhost newport input = case input of - VSend v -> setRedirectRequests newhost newport v +setRedirectRequests :: VChanConnections -> String -> String -> String -> Value -> IO () +setRedirectRequests vchanconmvar newhost newport ownport input = case input of + VSend v -> setRedirectRequests vchanconmvar newhost newport ownport v VPair v1 v2 -> do - setRedirectRequests newhost newport v1 - setRedirectRequests newhost newport v2 - VFunc penv a b -> setRedirectRequestsPEnv newhost newport penv - VDynCast v g -> setRedirectRequests newhost newport v - VFuncCast v a b -> setRedirectRequests newhost newport v - VRec penv a b c d -> setRedirectRequestsPEnv newhost newport penv - VNewNatRec penv a b c d e f g -> setRedirectRequestsPEnv newhost newport penv + setRedirectRequests vchanconmvar newhost newport ownport v1 + setRedirectRequests vchanconmvar newhost newport ownport v2 + VFunc penv a b -> setRedirectRequestsPEnv vchanconmvar newhost newport ownport penv + VDynCast v g -> setRedirectRequests vchanconmvar newhost newport ownport v + VFuncCast v a b -> setRedirectRequests vchanconmvar newhost newport ownport v + VRec penv a b c d -> setRedirectRequestsPEnv vchanconmvar newhost newport ownport penv + VNewNatRec penv a b c d e f g -> setRedirectRequestsPEnv vchanconmvar newhost newport ownport penv VChan nc _ -> do Config.traceNetIO $ "Trying to set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport SSem.withSem (ncHandlingIncomingMessage nc) (do oldconnectionstate <- MVar.takeMVar $ ncConnectionState nc - MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest (NCon.csHostname oldconnectionstate) (NCon.csPort oldconnectionstate) newhost newport + case oldconnectionstate of + Connected hostname port -> MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest hostname port newhost newport + RedirectRequest hostname port _ _ -> MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest hostname port newhost newport + Emulated -> do + Config.traceNetIO "TODO: Allow RedirectRequest for Emulated channel" + vchanconnections <- MVar.takeMVar vchanconmvar + + let userid = ncOwnUserID nc + let mbypartner = Map.lookup (Data.Maybe.fromMaybe "" userid) vchanconnections + case mbypartner of + Just partner -> do + MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest "127.0.0.1" ownport newhost newport -- Setting this to 127.0.0.1 is a temporary hack + oldconectionstatePartner <- MVar.takeMVar $ ncConnectionState partner + MVar.putMVar (ncConnectionState partner) $ NCon.Connected newhost newport + Nothing -> do + MVar.putMVar (ncConnectionState nc) oldconnectionstate + Config.traceNetIO "Error occured why getting the linked emulated channel" + + + MVar.putMVar vchanconmvar vchanconnections + Disconnected -> Config.traceNetIO "Cannot set RedirectRequest for a disconnected channel" ) Config.traceNetIO $ "Set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport _ -> return () where - setRedirectRequestsPEnv :: String -> String -> [(String, Value)] -> IO () - setRedirectRequestsPEnv _ _ [] = return () - setRedirectRequestsPEnv newhost newport (x:xs) = do - setRedirectRequests newhost newport $ snd x - setRedirectRequestsPEnv newhost newport xs + setRedirectRequestsPEnv :: VChanConnections -> String -> String -> String -> [(String, Value)] -> IO () + setRedirectRequestsPEnv _ _ _ _ [] = return () + setRedirectRequestsPEnv vchanconmvar newhost newport ownport (x:xs) = do + setRedirectRequests vchanconmvar newhost newport ownport $ snd x + setRedirectRequestsPEnv vchanconmvar newhost newport ownport xs replaceVChan :: Value -> IO Value replaceVChan input = case input of diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index b04bc24..d607051 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -69,8 +69,8 @@ newEmulatedConnection mvar = do incomingMsg2 <- SSem.new 1 let nc1 = NetworkConnection read write (Just userid2) (Just userid) connectionstate incomingMsg let nc2 = NetworkConnection read2 write2 (Just userid) (Just userid2) connectionstate2 incomingMsg2 - let ncmap1 = Map.insert userid nc1 ncmap - let ncmap2 = Map.insert userid2 nc2 ncmap1 + let ncmap1 = Map.insert userid2 nc1 ncmap + let ncmap2 = Map.insert userid nc2 ncmap1 MVar.putMVar mvar ncmap2 return (nc1, nc2) From 9a9c6332d3b45e72570e671984b0b55b52b75bb8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 7 Feb 2023 12:24:42 +0100 Subject: [PATCH 116/229] Added code to allow sending Emulated VChans There is still some things to do, but it seems to be working initially. --- src/Networking/Client.hs | 36 ++++++++++++- src/Networking/Common.hs | 4 +- src/Networking/NetworkingMethod/Fast.hs | 72 +++++++++++++------------ src/Networking/Server.hs | 42 +++++++++++++-- 4 files changed, 113 insertions(+), 41 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 94e0602..0a36f05 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -93,7 +93,9 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen case mbyresponse of Just response -> case response of Okay -> Config.traceNetIO $ "Message okay: "++serializedMessage - OkaySync history -> do + OkaySync historyraw -> do + -- let history = map (setPartnerHostAddress historyraw + let history = historyraw Config.traceNetIO $ "Message okay: "++serializedMessage serializedResponse <- NSerialize.serialize response Config.traceNetIO $ "Got syncronization values: "++serializedResponse @@ -127,6 +129,36 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen _ -> Config.traceNetIO "Error when sending message: This channel is disconnected while sending" +setPartnerHostAddress :: String -> Value -> Value +setPartnerHostAddress address input = case input of + VSend v -> VSend $ setPartnerHostAddress address v + VPair v1 v2 -> + let nv1 = setPartnerHostAddress address v1 in + let nv2 = setPartnerHostAddress address v2 in + VPair nv1 nv2 + VFunc penv a b -> + let newpenv = setPartnerHostAddressPEnv address penv in + VFunc newpenv a b + VDynCast v g -> VDynCast (setPartnerHostAddress address v) g + VFuncCast v a b -> VFuncCast (setPartnerHostAddress address v) a b + VRec penv a b c d -> + let newpenv = setPartnerHostAddressPEnv address penv in + VRec newpenv a b c d + VNewNatRec penv a b c d e f g -> + let newpenv = setPartnerHostAddressPEnv address penv in + VNewNatRec newpenv a b c d e f g + VChanSerial r w p o c -> do + let (hostname, port) = c + VChanSerial r w p o (if hostname == "" then address else hostname, port) + _ -> input -- return input + where + setPartnerHostAddressPEnv :: String -> [(String, Value)] -> [(String, Value)] + setPartnerHostAddressPEnv _ [] = [] + setPartnerHostAddressPEnv clientHostaddress penvs@(x:xs) = + let newval = setPartnerHostAddress clientHostaddress $ snd x in + (fst x, newval):setPartnerHostAddressPEnv clientHostaddress xs + + printConErr :: String -> String -> IOException -> IO () printConErr hostname port err = Config.traceIO $ "Communication Partner " ++ hostname ++ ":" ++ port ++ "not found!" @@ -198,7 +230,7 @@ setRedirectRequests vchanconmvar newhost newport ownport input = case input of let mbypartner = Map.lookup (Data.Maybe.fromMaybe "" userid) vchanconnections case mbypartner of Just partner -> do - MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest "127.0.0.1" ownport newhost newport -- Setting this to 127.0.0.1 is a temporary hack + MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest "" ownport newhost newport -- Setting this to 127.0.0.1 is a temporary hack oldconectionstatePartner <- MVar.takeMVar $ ncConnectionState partner MVar.putMVar (ncConnectionState partner) $ NCon.Connected newhost newport Nothing -> do diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 2db7e9a..d7befb9 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -36,4 +36,6 @@ endConversation con waitTime tries = NetMethod.endConversation con waitTime trie sayGoodbye con = NetMethod.sayGoodbye con -isClosed con = NetMethod.isClosed con \ No newline at end of file +isClosed con = NetMethod.isClosed con + + diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index 842c82d..696941e 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -24,7 +24,9 @@ import qualified Networking.NetworkingMethod.Stateless as Stateless import ProcessEnvironmentTypes import qualified Control.Concurrent.SSem as SSem -type Conversation = (String, Handle, MVar.MVar (Map.Map String (String, Responses)), SSem.SSem) +type ResponseMapMVar = MVar.MVar (Map.Map String (String, Responses)) + +data Conversation = Conversation {convID :: String, convHandle :: Handle, convRespMap :: ResponseMapMVar, convSending :: SSem.SSem} type ConnectionHandler = ActiveConnectionsFast -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Conversation -> String -> String -> Messages -> IO () @@ -35,14 +37,14 @@ type ConnectionHandler = ActiveConnectionsFast -> MVar.MVar (Map.Map String (Net sendMessage :: Conversation -> Messages -> IO () -sendMessage conversation@(cid, handle, responses, sem) value = SSem.withSem sem $ Stateless.sendMessage handle (ConversationMessage cid value) +sendMessage conv value = SSem.withSem (convSending conv) $ Stateless.sendMessage (convHandle conv) (ConversationMessage (convID conv) value) sendResponse :: Conversation -> Responses -> IO () -sendResponse conversation@(cid, handle, responses, sem) value = SSem.withSem sem $ Stateless.sendResponse handle (ConversationResponse cid value) +sendResponse conv value = SSem.withSem (convSending conv) $ Stateless.sendResponse (convHandle conv) (ConversationResponse (convID conv) value) conversationHandler :: Handle -> IO Connection conversationHandler handle = do - chan <- Chan.newChan + chan <- Chan.newChan mvar <- MVar.newEmptyMVar MVar.putMVar mvar Map.empty sem <- SSem.new 1 @@ -51,9 +53,9 @@ conversationHandler handle = do conversationHandlerChangeHandle handle chan mvar sem = do isClosed <- MVar.newEmptyMVar MVar.putMVar isClosed False - forkIO $ whileNotMVar isClosed (do + forkIO $ whileNotMVar isClosed (do -- Config.traceNetIO "Waiting for new conversation" - Stateless.recieveMessageInternal handle VG.parseConversation (\_ -> return ()) (\mes des -> do + Stateless.recieveMessageInternal handle VG.parseConversation (\_ -> return ()) (\mes des -> do -- Config.traceNetIO "Got new conversation" case des of ConversationMessage cid message -> Chan.writeChan chan (cid, (mes, message)) @@ -66,14 +68,14 @@ conversationHandlerChangeHandle handle chan mvar sem = do Config.traceNetIO $ "Recieved Message: " ++ mes MVar.takeMVar isClosed MVar.putMVar isClosed True - forkIO $ catch (do + forkIO $ catch (do closed <- hIsClosed handle unless closed $ hClose handle) onException return () ) ) return (handle, isClosed, chan, mvar, sem) - where + where whileNotMVar :: MVar.MVar Bool -> IO () -> IO () whileNotMVar mvar func = do shouldStop <- MVar.readMVar mvar @@ -87,27 +89,27 @@ conversationHandlerChangeHandle handle chan mvar sem = do recieveResponse :: Conversation -> Int -> Int -> IO (Maybe Responses) -recieveResponse conversation@(cid, handle, mvar, sem) waitTime tries = do +recieveResponse conv{-ersation@(cid, handle, mvar, sem)-} waitTime tries = do -- Config.traceNetIO "Trying to take mvar for responses mvar" - responsesMap <- MVar.takeMVar mvar + responsesMap <- MVar.takeMVar $ convRespMap conv -- Config.traceNetIO "Got MVar for responses" - case Map.lookup cid responsesMap of - Just (messages, deserial) -> do - MVar.putMVar mvar $ Map.delete cid responsesMap + case Map.lookup (convID conv) responsesMap of + Just (messages, deserial) -> do + MVar.putMVar (convRespMap conv) $ Map.delete (convID conv) responsesMap return $ Just deserial - Nothing -> do - MVar.putMVar mvar responsesMap - handleClosed <- hIsClosed handle + Nothing -> do + MVar.putMVar (convRespMap conv) responsesMap + handleClosed <- hIsClosed (convHandle conv) if tries /= 0 && not handleClosed then do -- Config.traceNetIO "Nothing yet retrying!" threadDelay waitTime - recieveResponse conversation waitTime $ max (tries-1) (-1) else return Nothing + recieveResponse conv waitTime $ max (tries-1) (-1) else return Nothing recieveNewMessage :: Connection -> IO (Conversation, String, Messages) recieveNewMessage connection@(handle, isClosed, chan, mvar, sem) = do (cid, (serial, deserial)) <- Chan.readChan chan - return ((cid, handle, mvar, sem), serial, deserial) - + return (Conversation cid handle mvar sem, serial, deserial) + startConversation :: ActiveConnectionsFast -> String -> String -> Int -> Int -> IO (Maybe Conversation) startConversation acmvar hostname port waitTime tries = do @@ -117,28 +119,28 @@ startConversation acmvar hostname port waitTime tries = do Just (handle, isClosed, chan, mvar, sem) -> do handleClosed <- MVar.readMVar isClosed if handleClosed then do - statelessActiveCons <- Stateless.createActiveConnections + statelessActiveCons <- Stateless.createActiveConnections mbyNewHandle <- Stateless.startConversation statelessActiveCons hostname port waitTime tries case mbyNewHandle of - Just handle -> do + Just handle -> do newconnection@(handle, isClosed, chan, mvar, sem) <- conversationHandlerChangeHandle handle chan mvar sem MVar.putMVar acmvar $ Map.insert (hostname, port) newconnection connectionMap - return $ Just (conversationid, handle, mvar, sem) - Nothing -> do + return $ Just (Conversation conversationid handle mvar sem) + Nothing -> do MVar.putMVar acmvar connectionMap return Nothing else do MVar.putMVar acmvar connectionMap - return $ Just (conversationid, handle, mvar, sem) + return $ Just (Conversation conversationid handle mvar sem) Nothing -> do - statelessActiveCons <- Stateless.createActiveConnections + statelessActiveCons <- Stateless.createActiveConnections mbyNewHandle <- Stateless.startConversation statelessActiveCons hostname port waitTime tries case mbyNewHandle of - Just handle -> do + Just handle -> do newconnection@(handle, isClosed, chan, mvar, sem) <- conversationHandler handle MVar.putMVar acmvar $ Map.insert (hostname, port) newconnection connectionMap - return $ Just (conversationid, handle, mvar, sem) - Nothing -> do + return $ Just (Conversation conversationid handle mvar sem) + Nothing -> do MVar.putMVar acmvar connectionMap return Nothing @@ -204,9 +206,9 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do hdl <- Stateless.getSocketFromHandle $ fst clientsocket connection@(handle, isClosed, chan, responsesMvar, sem) <- conversationHandler hdl -- NC.recieveMessage hdl VG.parseMessages (\_ -> return ()) $ connectionhandler mvar clientlist clientsocket hdl ownport - forkIO $ forever (do + forkIO $ forever (do (conversationid, (serial, deserial)) <- Chan.readChan chan - connectionhandler activeCons mvar clientlist clientsocket (conversationid, hdl, responsesMvar, sem) ownport serial deserial + connectionhandler activeCons mvar clientlist clientsocket (Conversation conversationid hdl responsesMvar sem) ownport serial deserial ) return () -- hClose hdl @@ -216,14 +218,14 @@ endConversation :: Conversation -> Int -> Int -> IO () endConversation _ _ _ = return () sayGoodbye :: ActiveConnectionsFast -> IO () -sayGoodbye activeCons = do +sayGoodbye activeCons = do activeConsMap <- MVar.readMVar activeCons let connections = Map.elems activeConsMap runAll sayGoodbyeConnection connections - where + where sayGoodbyeConnection :: Connection -> IO () sayGoodbyeConnection connection@(handle, isClosed, messages, responses, sem) = do - forkIO $ catch (do + forkIO $ catch (do handleClosed <- MVar.readMVar isClosed unless handleClosed $ SSem.withSem sem $ Stateless.sendMessage handle ConversationCloseAll unless handleClosed $ SSem.withSem sem $ hPutStr handle " " @@ -237,7 +239,7 @@ sayGoodbye activeCons = do runAll f xs onException :: IOException -> IO () onException _ = return () - + isClosed :: Conversation -> IO Bool -isClosed con@(conversationid, handle, mvar, sem) = hIsClosed handle +isClosed con = hIsClosed $ convHandle con diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index a9e57c7..f5a2767 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -40,6 +40,10 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria let userid = getUserID deserialmessages netcon <- MVar.readMVar mvar + clientHostaddress <- case snd clientsocket of + SockAddrInet _ hostname -> return $ hostaddressTypeToString hostname + _ -> return "" + -- MVar.putMVar mvar netcon case Map.lookup userid netcon of Just networkcon -> do -- SSem.withSem (ncHandlingIncomingMessage networkcon) $ do @@ -52,7 +56,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria unless redirectRequest $ case deserialmessages of NewValue userid count val -> do - handleNewValue activeCons mvar userid count val ownport hdl + handleNewValue activeCons mvar userid count val ownport clientHostaddress hdl IntroduceClient userid clientport syntype-> do handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype RequestSync userid count -> do @@ -110,9 +114,10 @@ checkAndSendRedirectRequest handle ncmap userid = do return True _ -> return False -handleNewValue :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> Int -> Value -> String -> NC.ConversationOrHandle -> IO () -handleNewValue activeCons mvar userid count val ownport hdl = do +handleNewValue :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> Int -> Value -> String -> String -> NC.ConversationOrHandle -> IO () +handleNewValue activeCons mvar userid count rawval ownport partneraddress hdl = do -- networkconnectionmap <- MVar.takeMVar mvar + let val = setPartnerHostAddress partneraddress rawval networkconnectionmap <- MVar.readMVar mvar case Map.lookup userid networkconnectionmap of Just networkconnection -> do @@ -128,6 +133,37 @@ handleNewValue activeCons mvar userid count val ownport hdl = do Config.traceNetIO "Error during recieving a networkmessage: Introduction is needed prior to sending values!" -- MVar.putMVar mvar networkconnectionmap + +setPartnerHostAddress :: String -> Value -> Value +setPartnerHostAddress address input = case input of + VSend v -> VSend $ setPartnerHostAddress address v + VPair v1 v2 -> + let nv1 = setPartnerHostAddress address v1 in + let nv2 = setPartnerHostAddress address v2 in + VPair nv1 nv2 + VFunc penv a b -> + let newpenv = setPartnerHostAddressPEnv address penv in + VFunc newpenv a b + VDynCast v g -> VDynCast (setPartnerHostAddress address v) g + VFuncCast v a b -> VFuncCast (setPartnerHostAddress address v) a b + VRec penv a b c d -> + let newpenv = setPartnerHostAddressPEnv address penv in + VRec newpenv a b c d + VNewNatRec penv a b c d e f g -> + let newpenv = setPartnerHostAddressPEnv address penv in + VNewNatRec newpenv a b c d e f g + VChanSerial r w p o c -> do + let (hostname, port) = c + VChanSerial r w p o (if hostname == "" then address else hostname, port) + _ -> input -- return input + where + setPartnerHostAddressPEnv :: String -> [(String, Value)] -> [(String, Value)] + setPartnerHostAddressPEnv _ [] = [] + setPartnerHostAddressPEnv clientHostaddress penvs@(x:xs) = + let newval = setPartnerHostAddress clientHostaddress $ snd x in + (fst x, newval):setPartnerHostAddressPEnv clientHostaddress xs + + contactNewPeers :: NMC.ActiveConnections -> Value -> String -> IO () contactNewPeers activeCons input ownport = case input of VSend v -> do From 2722d66d839f5ca3f963178769d93052ecf90b48 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 7 Feb 2023 13:41:24 +0100 Subject: [PATCH 117/229] More code towards improving handing of of emulated VChans --- src/Networking/Common.hs | 2 +- src/Networking/NetworkingMethod/Fast.hs | 21 ++--- .../NetworkingMethodCommon.hs | 5 +- src/Networking/NetworkingMethod/Stateless.hs | 88 ++++++++++--------- 4 files changed, 61 insertions(+), 55 deletions(-) diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index d7befb9..adefdb7 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -15,7 +15,7 @@ import qualified Networking.NetworkingMethod.Fast as NetMethod type ConversationOrHandle = NetMethod.Conversation --- type ConversationOrHandle = Handle +-- type ConversationOrHandle = (Handle, (Socket, SockAddr)) -- The compiler sadly compains when these things get eta reduced :/ sendMessage con ser = NetMethod.sendMessage con ser diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index 696941e..16b0a8f 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -26,7 +26,7 @@ import qualified Control.Concurrent.SSem as SSem type ResponseMapMVar = MVar.MVar (Map.Map String (String, Responses)) -data Conversation = Conversation {convID :: String, convHandle :: Handle, convRespMap :: ResponseMapMVar, convSending :: SSem.SSem} +data Conversation = Conversation {convID :: String, convHandle :: Stateless.Conversation, convRespMap :: ResponseMapMVar, convSending :: SSem.SSem} type ConnectionHandler = ActiveConnectionsFast -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Conversation -> String -> String -> Messages -> IO () @@ -42,7 +42,7 @@ sendMessage conv value = SSem.withSem (convSending conv) $ Stateless.sendMessage sendResponse :: Conversation -> Responses -> IO () sendResponse conv value = SSem.withSem (convSending conv) $ Stateless.sendResponse (convHandle conv) (ConversationResponse (convID conv) value) -conversationHandler :: Handle -> IO Connection +conversationHandler :: Stateless.Conversation -> IO Connection conversationHandler handle = do chan <- Chan.newChan mvar <- MVar.newEmptyMVar @@ -69,8 +69,8 @@ conversationHandlerChangeHandle handle chan mvar sem = do MVar.takeMVar isClosed MVar.putMVar isClosed True forkIO $ catch (do - closed <- hIsClosed handle - unless closed $ hClose handle) onException + closed <- hIsClosed $ fst handle + unless closed $ hClose $ fst handle) onException return () ) ) @@ -99,7 +99,7 @@ recieveResponse conv{-ersation@(cid, handle, mvar, sem)-} waitTime tries = do return $ Just deserial Nothing -> do MVar.putMVar (convRespMap conv) responsesMap - handleClosed <- hIsClosed (convHandle conv) + handleClosed <- hIsClosed $ fst (convHandle conv) if tries /= 0 && not handleClosed then do -- Config.traceNetIO "Nothing yet retrying!" threadDelay waitTime @@ -204,11 +204,12 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do acceptClient :: ActiveConnectionsFast -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> String -> IO () acceptClient activeCons connectionhandler mvar clientlist clientsocket ownport = do hdl <- Stateless.getSocketFromHandle $ fst clientsocket - connection@(handle, isClosed, chan, responsesMvar, sem) <- conversationHandler hdl + let statelessConv = (hdl, clientsocket) + connection@(handle, isClosed, chan, responsesMvar, sem) <- conversationHandler statelessConv -- NC.recieveMessage hdl VG.parseMessages (\_ -> return ()) $ connectionhandler mvar clientlist clientsocket hdl ownport forkIO $ forever (do (conversationid, (serial, deserial)) <- Chan.readChan chan - connectionhandler activeCons mvar clientlist clientsocket (Conversation conversationid hdl responsesMvar sem) ownport serial deserial + connectionhandler activeCons mvar clientlist clientsocket (Conversation conversationid statelessConv responsesMvar sem) ownport serial deserial ) return () -- hClose hdl @@ -224,10 +225,10 @@ sayGoodbye activeCons = do runAll sayGoodbyeConnection connections where sayGoodbyeConnection :: Connection -> IO () - sayGoodbyeConnection connection@(handle, isClosed, messages, responses, sem) = do + sayGoodbyeConnection connection@(statelessconv@(handle, _), isClosed, messages, responses, sem) = do forkIO $ catch (do handleClosed <- MVar.readMVar isClosed - unless handleClosed $ SSem.withSem sem $ Stateless.sendMessage handle ConversationCloseAll + unless handleClosed $ SSem.withSem sem $ Stateless.sendMessage statelessconv ConversationCloseAll unless handleClosed $ SSem.withSem sem $ hPutStr handle " " hFlushAll handle hClose handle @@ -242,4 +243,4 @@ sayGoodbye activeCons = do isClosed :: Conversation -> IO Bool -isClosed con = hIsClosed $ convHandle con +isClosed = hIsClosed . fst . convHandle diff --git a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs index 7186047..1ba20be 100644 --- a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs +++ b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs @@ -6,6 +6,7 @@ import qualified Control.Concurrent.MVar as MVar import qualified Data.Map as Map import Networking.Messages import qualified Control.Concurrent.SSem as SSem +import Network.Socket -- type ActiveConnections = ActiveConnectionsStateless @@ -13,7 +14,9 @@ type ActiveConnections = ActiveConnectionsFast data ActiveConnectionsStateless = ActiveConnectionsStateless -type Connection = (Handle, MVar.MVar Bool, Chan.Chan (String, (String, Messages)), MVar.MVar (Map.Map String (String, Responses)), SSem.SSem) +type ConversationStateless = (Handle, (Socket, SockAddr)) + +type Connection = (ConversationStateless, MVar.MVar Bool, Chan.Chan (String, (String, Messages)), MVar.MVar (Map.Map String (String, Responses)), SSem.SSem) -- isClosed Conversationid serial deserial type ActiveConnectionsFast = MVar.MVar (Map.Map NetworkAddress Connection) diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index 72b8207..98c7777 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -23,18 +23,19 @@ import qualified Syntax type ConnectionHandler = ActiveConnectionsStateless -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Messages -> IO () +type Conversation = ConversationStateless -sendMessage :: NSerialize.Serializable a => Handle -> a -> IO () -sendMessage handle value = do +sendMessage :: NSerialize.Serializable a => Conversation -> a -> IO () +sendMessage conv@(handle, _) value = do serializedValue <- NSerialize.serialize value hPutStrLn handle (serializedValue ++" ") -sendResponse :: NSerialize.Serializable a => Handle -> a -> IO () +sendResponse :: NSerialize.Serializable a => Conversation -> a -> IO () sendResponse = sendMessage -recieveMessageInternal :: Handle -> VT.Alex t -> (String -> IO b) -> (String -> t -> IO b) -> IO b -recieveMessageInternal handle grammar fallbackResponse messageHandler = do - waitWhileEOF handle +recieveMessageInternal :: Conversation -> VT.Alex t -> (String -> IO b) -> (String -> t -> IO b) -> IO b +recieveMessageInternal conv@(handle, _) grammar fallbackResponse messageHandler = do + waitWhileEOF conv message <- hGetLine handle case VT.runAlex message grammar of Left err -> do @@ -45,45 +46,45 @@ recieveMessageInternal handle grammar fallbackResponse messageHandler = do messageHandler message deserialmessage -waitWhileEOF :: Handle -> IO () -waitWhileEOF handle = do +waitWhileEOF :: Conversation -> IO () +waitWhileEOF conv@(handle, _) = do isEOF <- catch (hIsEOF handle) onException - when isEOF (do + when isEOF (do threadDelay 10000 - waitWhileEOF handle + waitWhileEOF conv ) where onException :: IOException -> IO Bool onException _ = return True -startConversation :: ActiveConnectionsStateless -> String -> String -> Int -> Int -> IO (Maybe Handle) +startConversation :: ActiveConnectionsStateless -> String -> String -> Int -> Int -> IO (Maybe Conversation) startConversation _ hostname port waitTime tries = do let hints = defaultHints { addrFamily = AF_INET , addrFlags = [] , addrSocketType = Stream } - handleMVar <- MVar.newEmptyMVar + convMVar <- MVar.newEmptyMVar threadid <- forkIO $ catch (do Config.traceNetIO $ "Trying to connect to: " ++ hostname ++":"++port addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port clientsocket <- openSocketNC $ head addrInfo connect clientsocket $ addrAddress $ head addrInfo handle <- getSocketFromHandle clientsocket - MVar.putMVar handleMVar handle + MVar.putMVar convMVar (handle, (clientsocket, addrAddress $ head addrInfo)) ) $ printConErr hostname port - getFromNetworkThread Nothing threadid handleMVar waitTime tries + getFromNetworkThread Nothing threadid convMVar waitTime tries printConErr :: String -> String -> IOException -> IO () printConErr hostname port err = Config.traceIO $ "startConversation: Communication Partner " ++ hostname ++ ":" ++ port ++ "not found!" -waitForConversation :: ActiveConnectionsStateless -> String -> String -> Int -> Int -> IO (Maybe Handle) +waitForConversation :: ActiveConnectionsStateless -> String -> String -> Int -> Int -> IO (Maybe Conversation) waitForConversation ac hostname port waitTime tries = do - mbyHandle <- startConversation ac hostname port waitTime tries - case mbyHandle of - Just handle -> return mbyHandle + mbyConv <- startConversation ac hostname port waitTime tries + case mbyConv of + Just conv -> return mbyConv Nothing -> waitForConversation ac hostname port waitTime tries @@ -102,7 +103,7 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do let updatedMap = Map.insert port newsocket sockets MVar.putMVar socketsmvar updatedMap return newsocket - where + where createServer :: ActiveConnectionsStateless -> ConnectionHandler -> Int -> VChanConnections -> IO (MVar.MVar [(String, Syntax.Type)]) createServer activeCons connectionhandler port vchanconnections = do -- serverid <- UserID.newRandomUserID @@ -134,44 +135,45 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do acceptClient :: ActiveConnectionsStateless -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> String -> IO () acceptClient activeCons connectionhandler mvar clientlist clientsocket ownport = do hdl <- getSocketFromHandle $ fst clientsocket - recieveMessageInternal hdl VG.parseMessages (\_ -> return ()) $ connectionhandler activeCons mvar clientlist clientsocket hdl ownport - hClose hdl + let conv = (hdl, clientsocket) + recieveMessageInternal conv VG.parseMessages (\_ -> return ()) $ connectionhandler activeCons mvar clientlist clientsocket hdl ownport + hClose hdl -getFromNetworkThread :: Maybe Handle -> ThreadId -> MVar.MVar a -> Int -> Int -> IO (Maybe a) -getFromNetworkThread handle = getFromNetworkThreadWithModification handle Just +getFromNetworkThread :: Maybe Conversation -> ThreadId -> MVar.MVar a -> Int -> Int -> IO (Maybe a) +getFromNetworkThread conv = getFromNetworkThreadWithModification conv Just -getFromNetworkThreadWithModification :: Maybe Handle -> (a -> Maybe b) -> ThreadId -> MVar a -> Int -> Int -> IO (Maybe b) -getFromNetworkThreadWithModification handle func threadid mvar waitTime currentTry = do +getFromNetworkThreadWithModification :: Maybe Conversation -> (a -> Maybe b) -> ThreadId -> MVar a -> Int -> Int -> IO (Maybe b) +getFromNetworkThreadWithModification conv func threadid mvar waitTime currentTry = do mbyResult <- MVar.tryReadMVar mvar case mbyResult of Just result -> return $ func result - Nothing -> do - handleClosed <- Data.Maybe.maybe (return False) hIsClosed handle - if currentTry /= 0 && not handleClosed then do + Nothing -> do + convClosed <- Data.Maybe.maybe (return False) (hIsClosed . fst) conv + if currentTry /= 0 && not convClosed then do threadDelay waitTime - getFromNetworkThreadWithModification handle func threadid mvar waitTime $ max (currentTry-1) (-1) + getFromNetworkThreadWithModification conv func threadid mvar waitTime $ max (currentTry-1) (-1) else do killThread threadid return Nothing -recieveResponse :: Handle -> Int -> Int -> IO (Maybe Responses) -recieveResponse handle waitTime tries = do +recieveResponse :: Conversation -> Int -> Int -> IO (Maybe Responses) +recieveResponse conv waitTime tries = do retVal <- MVar.newEmptyMVar - threadid <- forkIO $ recieveMessageInternal handle VG.parseResponses (\_ -> MVar.putMVar retVal Nothing) (\_ des -> MVar.putMVar retVal $ Just des) - getFromNetworkThreadWithModification (Just handle) id threadid retVal waitTime tries + threadid <- forkIO $ recieveMessageInternal conv VG.parseResponses (\_ -> MVar.putMVar retVal Nothing) (\_ des -> MVar.putMVar retVal $ Just des) + getFromNetworkThreadWithModification (Just conv) id threadid retVal waitTime tries + +recieveNewMessage :: Conversation -> IO (Conversation, String, Messages) +recieveNewMessage conv = do + recieveMessageInternal conv VG.parseMessages (\_ -> recieveNewMessage conv) $ \s des -> return (conv, s, des) -recieveNewMessage :: Handle -> IO (Handle, String, Messages) -recieveNewMessage handle = do - recieveMessageInternal handle VG.parseMessages (\_ -> recieveNewMessage handle) $ \s des -> return (handle, s, des) - -endConversation :: Handle -> Int -> Int -> IO () -endConversation handle waitTime tries = do +endConversation :: Conversation -> Int -> Int -> IO () +endConversation conv@(handle, _) waitTime tries = do finished <- MVar.newEmptyMVar threadid <- forkIO $ hClose handle >> MVar.putMVar finished True - _ <- getFromNetworkThread (Just handle) threadid finished waitTime tries + _ <- getFromNetworkThread (Just conv) threadid finished waitTime tries return () createActiveConnections :: IO ActiveConnectionsStateless @@ -184,7 +186,7 @@ getSocketFromHandle :: Socket -> IO Handle getSocketFromHandle socket = do hdl <- socketToHandle socket ReadWriteMode -- hSetBuffering hdl NoBuffering - hSetBuffering hdl LineBuffering + hSetBuffering hdl LineBuffering return hdl @@ -192,5 +194,5 @@ sayGoodbye :: ActiveConnectionsStateless -> IO () sayGoodbye _ = return () -isClosed :: Handle -> IO Bool -isClosed = hIsClosed \ No newline at end of file +isClosed :: Conversation -> IO Bool +isClosed = hIsClosed . fst \ No newline at end of file From 830976cd72a066df6002ed03a5ad4a80ee1580fb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 7 Feb 2023 13:57:59 +0100 Subject: [PATCH 118/229] Code for emulated vchan handoff is complete It's not yet sufficiently tested, but it seems to work from initial tests --- src/Networking/Client.hs | 3 ++- src/Networking/Common.hs | 2 ++ src/Networking/NetworkingMethod/Fast.hs | 3 +++ src/Networking/NetworkingMethod/Stateless.hs | 14 +++++++++++--- 4 files changed, 18 insertions(+), 4 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 0a36f05..ea762a2 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -95,7 +95,8 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen Okay -> Config.traceNetIO $ "Message okay: "++serializedMessage OkaySync historyraw -> do -- let history = map (setPartnerHostAddress historyraw - let history = historyraw + -- let history = historyraw + let history = map (setPartnerHostAddress $ NC.getPartnerHostaddress $ Data.Maybe.fromJust mbycon) historyraw Config.traceNetIO $ "Message okay: "++serializedMessage serializedResponse <- NSerialize.serialize response Config.traceNetIO $ "Got syncronization values: "++serializedResponse diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index adefdb7..2b79c1e 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -38,4 +38,6 @@ sayGoodbye con = NetMethod.sayGoodbye con isClosed con = NetMethod.isClosed con +getPartnerHostaddress conv = NetMethod.getPartnerHostaddress conv + diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index 16b0a8f..1584d3a 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -244,3 +244,6 @@ sayGoodbye activeCons = do isClosed :: Conversation -> IO Bool isClosed = hIsClosed . fst . convHandle + +getPartnerHostaddress :: Conversation -> String +getPartnerHostaddress = Stateless.getPartnerHostaddress . convHandle diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index 98c7777..30f05a3 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -189,10 +189,18 @@ getSocketFromHandle socket = do hSetBuffering hdl LineBuffering return hdl - sayGoodbye :: ActiveConnectionsStateless -> IO () sayGoodbye _ = return () - isClosed :: Conversation -> IO Bool -isClosed = hIsClosed . fst \ No newline at end of file +isClosed = hIsClosed . fst + +hostaddressTypeToString :: HostAddress -> String +hostaddressTypeToString hostaddress = do + let (a, b, c, d) = hostAddressToTuple hostaddress + show a ++ "." ++ show b ++ "."++ show c ++ "." ++ show d + +getPartnerHostaddress :: Conversation -> String +getPartnerHostaddress conv@(handle, (socket, sockAddress)) = case sockAddress of + SockAddrInet _ hostaddress -> hostaddressTypeToString hostaddress + _ -> "" \ No newline at end of file From 060add89b88f01678da318e95a8be23ef4efee69 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 8 Feb 2023 20:38:30 +0100 Subject: [PATCH 119/229] I think its more stable Still failed after 16000 runs of Handoff3 --- ldgv.cabal | 1 + package.yaml | 1 + src/Networking/DirectionalConnection.hs | 16 ++++++++++++---- testOftenHandoff3.sh | 3 +++ 4 files changed, 17 insertions(+), 4 deletions(-) create mode 100644 testOftenHandoff3.sh diff --git a/ldgv.cabal b/ldgv.cabal index d72db40..2525a08 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -106,6 +106,7 @@ library , base >=4.12 && <5 , bytestring , containers + , directory , file-embed , filepath , lens diff --git a/package.yaml b/package.yaml index 5fb8c78..f7fcbd3 100644 --- a/package.yaml +++ b/package.yaml @@ -64,6 +64,7 @@ library: - network-run - random - SafeSemaphore >=0.10.1 + - directory tests: ldgv-test: diff --git a/src/Networking/DirectionalConnection.hs b/src/Networking/DirectionalConnection.hs index b15d009..a905cb2 100644 --- a/src/Networking/DirectionalConnection.hs +++ b/src/Networking/DirectionalConnection.hs @@ -3,6 +3,8 @@ module Networking.DirectionalConnection where import Control.Concurrent.MVar import Control.Concurrent import qualified Control.Concurrent.SSem as SSem +import qualified System.Directory +import Control.Monad data DirectionalConnection a = DirectionalConnection { messages :: MVar [a], messagesUnreadStart :: MVar Int, messagesCount :: MVar Int, readLock :: SSem.SSem} deriving Eq @@ -70,17 +72,23 @@ readUnreadMessage connection = do maybeval <- readUnreadMessageMaybe connection case maybeval of Nothing -> do - threadDelay 1000 + threadDelay 5000 readUnreadMessage connection Just val -> return val readUnreadMessageInterpreter :: DirectionalConnection a -> IO a -readUnreadMessageInterpreter connection = do +readUnreadMessageInterpreter connection = do + -- debugExists <- System.Directory.doesFileExist "print.me" + -- when debugExists $ putStrLn "DC: Trying to read message" maybeval <- SSem.withSem (readLock connection) $ readUnreadMessageMaybe connection + -- when debugExists $ putStrLn "DC: Read message" + -- allVals <- countMessages connection + -- currentRead <- readMVar $ messagesUnreadStart connection + -- when debugExists $ putStrLn $ "DC: "++ show currentRead++" out of "++show allVals case maybeval of Nothing -> do - threadDelay 1000 - readUnreadMessage connection + threadDelay 5000 + readUnreadMessageInterpreter connection Just val -> return val serializeConnection :: DirectionalConnection a -> IO ([a], Int) diff --git a/testOftenHandoff3.sh b/testOftenHandoff3.sh new file mode 100644 index 0000000..c059b0c --- /dev/null +++ b/testOftenHandoff3.sh @@ -0,0 +1,3 @@ +for i in {1..20000}; do + clear; echo "$i Handoff3"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff3/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/client.ldgvnw & wait); +done \ No newline at end of file From d6ac3172cfad85d9d8671c1937b7a037d301e564 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 9 Feb 2023 10:32:44 +0100 Subject: [PATCH 120/229] Fixed Stateless networking Stateless networking seems to be stable --- src/Networking/Common.hs | 4 ++-- src/Networking/NetworkingMethod/NetworkingMethodCommon.hs | 4 ++-- src/Networking/NetworkingMethod/Stateless.hs | 4 ++-- testOftenHandoff3.sh | 2 +- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 2b79c1e..d0bc64a 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -9,8 +9,8 @@ import qualified Networking.Serialize as NSerialize import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG import qualified Config --- import qualified Networking.NetworkingMethod.Stateless as NetMethod -import qualified Networking.NetworkingMethod.Fast as NetMethod +import qualified Networking.NetworkingMethod.Stateless as NetMethod +-- import qualified Networking.NetworkingMethod.Fast as NetMethod type ConversationOrHandle = NetMethod.Conversation diff --git a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs index 1ba20be..4b27bb2 100644 --- a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs +++ b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs @@ -8,9 +8,9 @@ import Networking.Messages import qualified Control.Concurrent.SSem as SSem import Network.Socket --- type ActiveConnections = ActiveConnectionsStateless +type ActiveConnections = ActiveConnectionsStateless -type ActiveConnections = ActiveConnectionsFast +-- type ActiveConnections = ActiveConnectionsFast data ActiveConnectionsStateless = ActiveConnectionsStateless diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index 30f05a3..13a6b66 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -21,7 +21,7 @@ import qualified ValueParsing.ValueGrammar as VG import qualified Config import qualified Syntax -type ConnectionHandler = ActiveConnectionsStateless -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Messages -> IO () +type ConnectionHandler = ActiveConnectionsStateless -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Conversation -> String -> String -> Messages -> IO () type Conversation = ConversationStateless @@ -136,7 +136,7 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do acceptClient activeCons connectionhandler mvar clientlist clientsocket ownport = do hdl <- getSocketFromHandle $ fst clientsocket let conv = (hdl, clientsocket) - recieveMessageInternal conv VG.parseMessages (\_ -> return ()) $ connectionhandler activeCons mvar clientlist clientsocket hdl ownport + recieveMessageInternal conv VG.parseMessages (\_ -> return ()) $ connectionhandler activeCons mvar clientlist clientsocket conv ownport hClose hdl diff --git a/testOftenHandoff3.sh b/testOftenHandoff3.sh index c059b0c..5c3ba4e 100644 --- a/testOftenHandoff3.sh +++ b/testOftenHandoff3.sh @@ -1,3 +1,3 @@ -for i in {1..20000}; do +for i in {1..200000}; do clear; echo "$i Handoff3"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff3/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/client.ldgvnw & wait); done \ No newline at end of file From adbda710123cdea647d66125aa647ed36fdfec95 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 9 Feb 2023 15:51:07 +0100 Subject: [PATCH 121/229] new type signatures --- log/FastNetworkingBug6.log | 568 ++++++++++++++++++ src/Interpreter.hs | 22 +- src/Networking/Client.hs | 6 +- src/Networking/Common.hs | 4 +- src/Networking/Messages.hs | 4 +- src/Networking/NetworkingMethod/Fast.hs | 8 +- .../NetworkingMethodCommon.hs | 4 +- src/Networking/NetworkingMethod/Stateless.hs | 8 +- src/Networking/Serialize.hs | 2 +- src/Networking/Server.hs | 31 +- src/ProcessEnvironmentTypes.hs | 2 +- src/ValueParsing/ValueGrammar.y | 2 +- 12 files changed, 624 insertions(+), 37 deletions(-) create mode 100644 log/FastNetworkingBug6.log diff --git a/log/FastNetworkingBug6.log b/log/FastNetworkingBug6.log new file mode 100644 index 0000000..2b92335 --- /dev/null +++ b/log/FastNetworkingBug6.log @@ -0,0 +1,568 @@ +2 Bidirhandoff +subtype: Entering [(c, (0, SendInt))] (Nat) (Int) +subtype: Entering [ (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Nat) (Int) +subtype: Entering [ (y2, (_, ())) +, (m, (_, Int)) +, (y, (0, ?Int. ())) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Int) (Int) +subtype: Entering [(c, (0, SendInt))] (Nat) (Int) +subtype: Entering [ (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Nat) (Int) +subtype: Entering [ (y2, (_, ())) +, (m, (_, Int)) +, (y, (0, ?Int. ())) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Int) (Int) +subtype: Entering [ (y2, (_, ())) +, (m, (_, Int)) +, (y, (0, ?Int. ())) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Int) (Int) +subtype: Entering [ (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (c32, (_, ())) +, (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: Entering [ (c32, (_, ())) +, (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: Entering [ (c2, (0, !Int. ())) +, (m, (_, Int)) +, (c1, (_, ())) +, (talk, (0, SendIntServer)) +, (con, (0, ~SendSendIntServer)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +Trying to connect to: 127.0.0.1:4242 +subtype: Entering [(c, (0, SendInt))] (Nat) (Int) +subtype: Entering [ (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Nat) (Int) +subtype: Entering [ (y2, (_, ())) +, (m, (_, Int)) +, (y, (0, ?Int. ())) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Int) (Int) +subtype: Entering [(c, (0, SendInt))] (Nat) (Int) +subtype: Entering [ (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Nat) (Int) +subtype: Entering [ (y2, (_, ())) +, (m, (_, Int)) +, (y, (0, ?Int. ())) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Int) (Int) +subtype: Entering [ (y2, (_, ())) +, (m, (_, Int)) +, (y, (0, ?Int. ())) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Int) (Int) +subtype: Entering [ (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (c32, (_, ())) +, (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: Entering [ (c32, (_, ())) +, (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: Entering [ (y, (_, ())) +, (talk, (0, SendIntClient)) +, (con, (0, ~SendSendIntClient)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: Entering [ (y2, (_, ())) +, (m, (_, Int)) +, (y, (0, ?Int. ())) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Int) (Int) +subtype: Entering [ (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (c32, (_, ())) +, (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: Entering [ (c32, (_, ())) +, (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: Entering [ (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (con, (0, ~SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (con2, (0, SendSendIntServer)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (con, (0, ~SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (?Int. !Int. ()) (SendIntServer) +subtype: Entering [ (con2, (0, SendSendIntServer)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (con, (0, ~SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (?Int. !Int. ()) (?Int. !Int. ()) +subtype: Entering [ (y2, (_, ())) +, (m, (_, Int)) +, (y, (0, ?Int. ())) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (c, (0, SendInt)) ] (Int) (Int) +subtype: Entering [ (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (c32, (_, ())) +, (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: Entering [ (c32, (_, ())) +, (c3, (0, !Int. ())) +, (n, (_, Int)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (c1, (0, ~SendInt)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: Entering [ (con, (0, SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) +subtype: Entering [ (con2, (0, SendSendIntClient)) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (con, (0, SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (!Int. ?Int. ()) (SendIntClient) +subtype: Entering [ (con2, (0, SendSendIntClient)) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (con, (0, SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (!Int. ?Int. ()) (!Int. ?Int. ()) +subtype: Entering [ (con2, (0, SendSendIntServer)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (con, (0, ~SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: [ (con2, (0, SendSendIntServer)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (con, (0, ~SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) = Kunit +subtype: Entering [ (zz8, (_, Int)) +, (con2, (0, SendSendIntServer)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (con, (0, ~SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (!Int. ()) (!Int. ()) +subtype: Entering [ (zz8, (_, Int)) +, (con2, (0, SendSendIntServer)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (con, (0, ~SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: [ (zz8, (_, Int)) +, (con2, (0, SendSendIntServer)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (con, (0, ~SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) = Kunit +subtype: Entering [ (zz9, (_, Int)) +, (zz8, (_, Int)) +, (con2, (0, SendSendIntServer)) +, (c22, (0, ?Int. !Int. ())) +, (c2, (0, !Int. ?Int. !Int. ())) +, (m, (_, Int)) +, (con, (0, ~SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (()) (()) +subtype: Entering [ (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: Entering [ (con2, (0, SendSendIntClient)) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (con, (0, SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: [ (con2, (0, SendSendIntClient)) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (con, (0, SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) = Kunit +subtype: Entering [ (zz8, (_, Int)) +, (con2, (0, SendSendIntClient)) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (con, (0, SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (?Int. ()) (?Int. ()) +subtype: Entering [ (zz8, (_, Int)) +, (con2, (0, SendSendIntClient)) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (con, (0, SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +subtype: [ (zz8, (_, Int)) +, (con2, (0, SendSendIntClient)) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (con, (0, SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) = Kunit +subtype: Entering [ (zz9, (_, Int)) +, (zz8, (_, Int)) +, (con2, (0, SendSendIntClient)) +, (x2, (0, !Int. ?Int. ())) +, (n, (_, Int)) +, (x, (0, ?Int. !Int. ?Int. ())) +, (con, (0, SendInt)) +, (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (()) (()) +subtype: Entering [ (main, (_, Int)) +, (add2, (_, (c1 : ~SendInt) -> Int)) +, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) +Trying to connect to: 127.0.0.1:4242 +Recieved message from unknown connection! + Response to 7rgEnvHL: NOkayIntroduce (String:"nISByehk") + Message: NConversationMessage (String:"shD3v8xj") (NIntroduceClient (String:"7rgEnvHL") (String:"4343") (TName (Bool:False) (String:"SendInt")) (TSend (String:"#!") (TInt) (TRecv (String:"#?") (TInt) (TSend (String:"#!") (TInt) (TRecv (String:"#?") (TInt) (TUnit)))))) +Sending message as: 7rgEnvHL to: nISByehk + Over: 127.0.0.1:4242 +Trying to connect to: 127.0.0.1:4242 + Message: NIntroduceClient (String:"7rgEnvHL") (String:"4343") (TName (Bool:False) (String:"SendInt")) (TSend (String:"#!") (TInt) (TRecv (String:"#?") (TInt) (TSend (String:"#!") (TInt) (TRecv (String:"#?") (TInt) (TUnit))))) +Sending message as: 7rgEnvHL to: nISByehk + Over: 127.0.0.1:4242 + Message: NNewValue (String:"7rgEnvHL") (Int:1) (VInt (Int:1)) +Recieved message from unknown connection! + Response to 4MHbSLnZ: NOkayIntroduce (String:"qZXgVJiD") + Message: NConversationMessage (String:"yCLqfaI7") (NIntroduceClient (String:"4MHbSLnZ") (String:"4240") (TName (Bool:True) (String:"SendSendIntServer")) (TSend (String:"#!") (TName (Bool:False) (String:"SendIntServer")) (TUnit))) +Recieved message as: nISByehk (4242) from: 7rgEnvHL + NConversationMessage (String:"KPyBCp2x") (NNewValue (String:"7rgEnvHL") (Int:1) (VInt (Int:1))) + Message: NConversationMessage (String:"KPyBCp2x") (NNewValue (String:"7rgEnvHL") (Int:1) (VInt (Int:1))) +Sending message as: nISByehk to: 7rgEnvHL + Over: 127.0.0.1:4343 + Message: NNewValue (String:"nISByehk") (Int:1) (VInt (Int:1300)) +Trying to connect to: 127.0.0.1:4343 +Sending message as: 4MHbSLnZ to: qZXgVJiD + Over: 127.0.0.1:4242 + Message: NIntroduceClient (String:"4MHbSLnZ") (String:"4240") (TName (Bool:True) (String:"SendSendIntServer")) (TSend (String:"#!") (TName (Bool:False) (String:"SendIntServer")) (TUnit)) +Message okay: NNewValue (String:"7rgEnvHL") (Int:1) (VInt (Int:1)) +Recieved message as: 7rgEnvHL (4343) from: nISByehk + NConversationMessage (String:"9dblOYp2") (NNewValue (String:"nISByehk") (Int:1) (VInt (Int:1300))) + Message: NConversationMessage (String:"9dblOYp2") (NNewValue (String:"nISByehk") (Int:1) (VInt (Int:1300))) +Trying to connect to: 127.0.0.1:4340 +Recieved message from unknown connection! + Response to 7tTIigo7: NOkayIntroduce (String:"MiquZROF") + Message: NConversationMessage (String:"jVHOkaFZ") (NIntroduceClient (String:"7tTIigo7") (String:"4343") (TName (Bool:False) (String:"SendSendIntClient")) (TSend (String:"#!") (TName (Bool:False) (String:"SendIntClient")) (TUnit))) +Message okay: NNewValue (String:"nISByehk") (Int:1) (VInt (Int:1300)) +Trying to set RedirectRequest for 7rgEnvHL to 127.0.0.1:4240 +Set RedirectRequest for 7rgEnvHL to 127.0.0.1:4240 +Sending message as: qZXgVJiD to: 4MHbSLnZ + Over: 127.0.0.1:4240 + Message: NNewValue (String:"qZXgVJiD") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray [VInt (Int:1300)]) (Int:0))) (String:"7rgEnvHL") (String:"nISByehk") (((String:"127.0.0.1") (String:"4343")))) +Trying to connect to: 127.0.0.1:4240 +Sending message as: 7tTIigo7 to: MiquZROF + Over: 127.0.0.1:4340 + Message: NIntroduceClient (String:"7tTIigo7") (String:"4343") (TName (Bool:False) (String:"SendSendIntClient")) (TSend (String:"#!") (TName (Bool:False) (String:"SendIntClient")) (TUnit)) +Trying to set RedirectRequest for nISByehk to 127.0.0.1:4340 +Set RedirectRequest for nISByehk to 127.0.0.1:4340 +Sending message as: 7tTIigo7 to: MiquZROF + Over: 127.0.0.1:4340 + Message: NNewValue (String:"7tTIigo7") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"nISByehk") (String:"7rgEnvHL") (((String:"127.0.0.1") (String:"4242")))) +Recieved message as: MiquZROF (4340) from: 7tTIigo7 + NConversationMessage (String:"r4mVhKcq") (NNewValue (String:"7tTIigo7") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"nISByehk") (String:"7rgEnvHL") (((String:"127.0.0.1") (String:"4242"))))) +Sending message as: 7rgEnvHL to: nISByehk + Over: 127.0.0.1:4242 + Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") +Trying to connect to: 127.0.0.1:4242 +Recieved message as: 4MHbSLnZ (4240) from: qZXgVJiD + NConversationMessage (String:"vn4kpvnc") (NNewValue (String:"qZXgVJiD") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray [VInt (Int:1300)]) (Int:0))) (String:"7rgEnvHL") (String:"nISByehk") (((String:"127.0.0.1") (String:"4343"))))) +Sending message as: nISByehk to: 7rgEnvHL + Over: 127.0.0.1:4343 + Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") +Trying to connect to: 127.0.0.1:4343 +Recieved message as: nISByehk (4242) from: 7rgEnvHL + NConversationMessage (String:"mc7wMrHY") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) +Found redirect request for: 7rgEnvHL +Send redirect to:127.0.0.1:4240 + Message: NConversationMessage (String:"mc7wMrHY") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) +Recieved message as: 7rgEnvHL (4343) from: nISByehk + NConversationMessage (String:"jzQaGVfj") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) +Found redirect request for: nISByehk +Send redirect to:127.0.0.1:4340 + Message: NConversationMessage (String:"jzQaGVfj") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) +Communication partner changed address, resending +Sending message as: 7rgEnvHL to: nISByehk + Over: 127.0.0.1:4240 + Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") +Trying to connect to: 127.0.0.1:4240 +Communication partner changed address, resending +Sending message as: nISByehk to: 7rgEnvHL + Over: 127.0.0.1:4340 + Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") +Trying to connect to: 127.0.0.1:4340 +Recieved message from unknown connection! + Message: NConversationMessage (String:"PiKTMZk3") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) +Recieved message from unknown connection! + Message: NConversationMessage (String:"Wgc8VSWd") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) +Communication out of sync lets wait! +Communication out of sync lets wait! +Sending message as: 7rgEnvHL to: nISByehk + Over: 127.0.0.1:4240 + Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") +Recieved message from unknown connection! + Message: NConversationMessage (String:"8tRv7zEU") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) +Sending message as: nISByehk to: 7rgEnvHL + Over: 127.0.0.1:4340 + Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") +Recieved message from unknown connection! + Message: NConversationMessage (String:"nsMTLUV5") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) +Communication out of sync lets wait! +Communication out of sync lets wait! +Sending message as: 7rgEnvHL to: nISByehk + Over: 127.0.0.1:4240 + Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") +Recieved message from unknown connection! + Message: NConversationMessage (String:"psB35Ww8") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) +Sending message as: nISByehk to: 7rgEnvHL + Over: 127.0.0.1:4340 + Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") +Recieved message from unknown connection! + Message: NConversationMessage (String:"NHp37pNy") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) +Communication out of sync lets wait! +Communication out of sync lets wait! +Sending message as: 7rgEnvHL to: nISByehk + Over: 127.0.0.1:4240 + Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") +Recieved message from unknown connection! + Message: NConversationMessage (String:"XGzPe347") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) +Sending message as: nISByehk to: 7rgEnvHL + Over: 127.0.0.1:4340 + Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") +Recieved message from unknown connection! + Message: NConversationMessage (String:"nc4kbQGE") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) +Communication out of sync lets wait! +Communication out of sync lets wait! +Sending message as: 7rgEnvHL to: nISByehk + Over: 127.0.0.1:4240 + Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") +Recieved message from unknown connection! + Message: NConversationMessage (String:"65nMnuAF") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) +Sending message as: nISByehk to: 7rgEnvHL + Over: 127.0.0.1:4340 + Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") +Recieved message from unknown connection! + Message: NConversationMessage (String:"gWXy1btd") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) +Communication out of sync lets wait! +Communication out of sync lets wait! +Sending message as: 7rgEnvHL to: nISByehk + Over: 127.0.0.1:4240 + Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") +Recieved message from unknown connection! + Message: NConversationMessage (String:"wsiXKJj6") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) +Sending message as: nISByehk to: 7rgEnvHL + Over: 127.0.0.1:4340 + Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") +Recieved message from unknown connection! + Message: NConversationMessage (String:"F8J2w78a") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) +Communication out of sync lets wait! +Communication out of sync lets wait! +^VSending message as: 7rgEnvHL to: nISByehk + Over: 127.0.0.1:4240 + Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") +Recieved message from unknown connection! + Message: NConversationMessage (String:"6e1XCkd1") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) +Sending message as: nISByehk to: 7rgEnvHL + Over: 127.0.0.1:4340 + Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") +Recieved message from unknown connection! + Message: NConversationMessage (String:"lFGrxfAz") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) +Communication out of sync lets wait! +Communication out of sync lets wait! +Sending message as: 7rgEnvHL to: nISByehk + Over: 127.0.0.1:4240 + Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") +Recieved message from unknown connection! + Message: NConversationMessage (String:"E7AhHqgg") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) +Sending message as: nISByehk to: 7rgEnvHL + Over: 127.0.0.1:4340 + Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") +Recieved message from unknown connection! + Message: NConversationMessage (String:"E8i7UHZA") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) +Communication out of sync lets wait! +Communication out of sync lets wait! +Sending message as: 7rgEnvHL to: nISByehk + Over: 127.0.0.1:4240 + Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") +Recieved message from unknown connection! + Message: NConversationMessage (String:"zXWZieG6") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) +Sending message as: nISByehk to: 7rgEnvHL + Over: 127.0.0.1:4340 + Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") +Recieved message from unknown connection! + Message: NConversationMessage (String:"jVfvJugy") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) +Communication out of sync lets wait! +Communication out of sync lets wait! +Sending message as: 7rgEnvHL to: nISByehk + Over: 127.0.0.1:4240 + Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") +Recieved message from unknown connection! + Message: NConversationMessage (String:"846ygNLv") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) +Sending message as: nISByehk to: 7rgEnvHL + Over: 127.0.0.1:4340 + Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") +Recieved message from unknown connection! + Message: NConversationMessage (String:"mGc2GaJY") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) +Communication out of sync lets wait! +Communication out of sync lets wait! +Sending message as: 7rgEnvHL to: nISByehk + Over: 127.0.0.1:4240 + Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") +Recieved message from unknown connection! + Message: NConversationMessage (String:"VUuwAOk8") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) +Sending message as: nISByehk to: 7rgEnvHL + Over: 127.0.0.1:4340 + Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") +Recieved message from unknown connection! + Message: NConversationMessage (String:"WLnyAVFy") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) +Communication out of sync lets wait! +Communication out of sync lets wait! +^C[laeuferle@workbench ldgvnetworking]$ ^C +[laeuferle@workbench ldgvnetworking]$ ^C +[laeuferle@workbench ldgvnetworking]$ \ No newline at end of file diff --git a/src/Interpreter.hs b/src/Interpreter.hs index dcaf805..c7f099c 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -43,6 +43,7 @@ import qualified Networking.UserID as UserID import qualified Networking.Messages as Messages import qualified Networking.DirectionalConnection as DC import qualified Networking.NetworkConnection as NCon +import qualified Networking.Serialize -- import ProcessEnvironment (CommunicationChannel(CommunicationChannel, ccChannelState, ccPartnerUserID), ConnectionInfo (ciReadChannel, ciWriteChannel)) -- import ProcessEnvironment import qualified Control.Concurrent as MVar @@ -208,7 +209,7 @@ eval = \case newV <- liftIO $ disableOldVChan v return $ VPair val newV Case e cases -> interpret' e >>= \(VLabel s) -> interpret' $ fromJust $ lookup s cases - Accept e t -> do + Accept e tname -> do liftIO $ C.traceIO "Accepting new client!" val <- interpret' e @@ -218,7 +219,16 @@ eval = \case (clientlist, ownport) <- liftIO $ NC.acceptConversations activeConnections NS.handleClient port sockets vchanconnections -- newuser <- liftIO $ Chan.readChan chan liftIO $ C.traceIO "Searching for correct communicationpartner" - newuser <- liftIO $ NS.findFittingClient clientlist t -- There is still an issue + + + t <- case tname of + TName _ s -> maybe (throw $ LookupException s) (\(VType t) -> return t) (lookup s env) + _ -> return tname + + -- tserial <- liftIO $ Networking.Serialize.serialize t + -- C.traceNetIO $ "Interpreter: " ++ tserial + + newuser <- liftIO $ NS.findFittingClient clientlist (tname, t) -- There is still an issue liftIO $ C.traceIO "Client accepted" networkconnectionmap <- liftIO $ MVar.readMVar vchanconnections case Map.lookup newuser networkconnectionmap of @@ -230,7 +240,7 @@ eval = \case return $ VChan networkconnection used _ -> throw $ NotAnExpectedValueException "VInt" val - Connect e0 t e1 e2-> do + Connect e0 tname e1 e2-> do r <- liftIO DC.newConnection w <- liftIO DC.newConnection liftIO $ C.traceIO "Client trying to connect" @@ -245,7 +255,11 @@ eval = \case portVal <- interpret' e2 case portVal of VInt port -> do - liftIO $ NClient.initialConnect activeConnections vchanconnections address (show port) ownport t + t <- case tname of + TName _ s -> maybe (throw $ LookupException s) (\(VType t) -> return t) (lookup s env) + _ -> return tname + + liftIO $ NClient.initialConnect activeConnections vchanconnections address (show port) ownport (tname, t) _ -> throw $ NotAnExpectedValueException "VInt" portVal _ -> throw $ NotAnExpectedValueException "VString" addressVal _ -> throw $ NotAnExpectedValueException "VInt" val diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index ea762a2..1c5ab45 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -164,20 +164,20 @@ printConErr :: String -> String -> IOException -> IO () printConErr hostname port err = Config.traceIO $ "Communication Partner " ++ hostname ++ ":" ++ port ++ "not found!" -initialConnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> Syntax.Type -> IO Value +initialConnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> (Syntax.Type, Syntax.Type) -> IO Value initialConnect activeCons mvar hostname port ownport syntype= do mbycon <- NC.waitForConversation activeCons hostname port 1000 100 -- This should be 10000 100 in the real world, expecting just a 100ms ping in the real world might be a little aggressive. case mbycon of Just con -> do ownuserid <- UserID.newRandomUserID - NC.sendMessage con (Messages.IntroduceClient ownuserid ownport syntype) + NC.sendMessage con (Messages.IntroduceClient ownuserid ownport (fst syntype) $ snd syntype) mbyintroductionanswer <- NC.recieveResponse con 10000 (-1) NC.endConversation con 10000 10 case mbyintroductionanswer of Just introduction -> case introduction of OkayIntroduce introductionanswer -> do - msgserial <- NSerialize.serialize $ Messages.IntroduceClient ownuserid ownport syntype + msgserial <- NSerialize.serialize $ Messages.IntroduceClient ownuserid ownport (fst syntype) $ snd syntype Config.traceNetIO $ "Sending message as: " ++ ownuserid ++ " to: " ++ introductionanswer Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port Config.traceNetIO $ " Message: " ++ msgserial diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index d0bc64a..2b79c1e 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -9,8 +9,8 @@ import qualified Networking.Serialize as NSerialize import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG import qualified Config -import qualified Networking.NetworkingMethod.Stateless as NetMethod --- import qualified Networking.NetworkingMethod.Fast as NetMethod +-- import qualified Networking.NetworkingMethod.Stateless as NetMethod +import qualified Networking.NetworkingMethod.Fast as NetMethod type ConversationOrHandle = NetMethod.Conversation diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs index 336f6a4..673e273 100644 --- a/src/Networking/Messages.hs +++ b/src/Networking/Messages.hs @@ -11,7 +11,7 @@ type Port = String type ConversationID = String data Messages - = IntroduceClient UserID Port Type + = IntroduceClient UserID Port Type Type | NewValue UserID Int Value | SyncIncoming UserID [Value] | RequestSync UserID Int @@ -32,7 +32,7 @@ data ConversationSession getUserID :: Messages -> String getUserID = \case - IntroduceClient p _ _ -> p + IntroduceClient p _ _ _ -> p NewValue p _ _ -> p SyncIncoming p _ -> p RequestSync p _ -> p diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index 1584d3a..d3d82f3 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -28,7 +28,7 @@ type ResponseMapMVar = MVar.MVar (Map.Map String (String, Responses)) data Conversation = Conversation {convID :: String, convHandle :: Stateless.Conversation, convRespMap :: ResponseMapMVar, convSending :: SSem.SSem} -type ConnectionHandler = ActiveConnectionsFast -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Conversation -> String -> String -> Messages -> IO () +type ConnectionHandler = ActiveConnectionsFast -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> Conversation -> String -> String -> Messages -> IO () -- type NetworkAddress = (String, String) -- deriving (Eq, Show, Ord) @@ -174,7 +174,7 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do MVar.putMVar socketsmvar updatedMap return newsocket where - createServer :: ActiveConnectionsFast -> ConnectionHandler -> Int -> VChanConnections -> IO (MVar.MVar [(String, Syntax.Type)]) + createServer :: ActiveConnectionsFast -> ConnectionHandler -> Int -> VChanConnections -> IO (MVar.MVar [(String, (Syntax.Type, Syntax.Type))]) createServer activeCons connectionhandler port vchanconnections = do -- serverid <- UserID.newRandomUserID sock <- socket AF_INET Stream 0 @@ -192,7 +192,7 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do forkIO $ acceptClients activeCons connectionhandler vchanconnections clientlist sock $ show port return clientlist - acceptClients :: ActiveConnectionsFast -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> Socket -> String -> IO () + acceptClients :: ActiveConnectionsFast -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> Socket -> String -> IO () acceptClients activeCons connectionhandler mvar clientlist socket ownport = do Config.traceIO "Waiting for clients" clientsocket <- accept socket @@ -201,7 +201,7 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do forkIO $ acceptClient activeCons connectionhandler mvar clientlist clientsocket ownport acceptClients activeCons connectionhandler mvar clientlist socket ownport - acceptClient :: ActiveConnectionsFast -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> String -> IO () + acceptClient :: ActiveConnectionsFast -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> String -> IO () acceptClient activeCons connectionhandler mvar clientlist clientsocket ownport = do hdl <- Stateless.getSocketFromHandle $ fst clientsocket let statelessConv = (hdl, clientsocket) diff --git a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs index 4b27bb2..1ba20be 100644 --- a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs +++ b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs @@ -8,9 +8,9 @@ import Networking.Messages import qualified Control.Concurrent.SSem as SSem import Network.Socket -type ActiveConnections = ActiveConnectionsStateless +-- type ActiveConnections = ActiveConnectionsStateless --- type ActiveConnections = ActiveConnectionsFast +type ActiveConnections = ActiveConnectionsFast data ActiveConnectionsStateless = ActiveConnectionsStateless diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index 13a6b66..0389114 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -21,7 +21,7 @@ import qualified ValueParsing.ValueGrammar as VG import qualified Config import qualified Syntax -type ConnectionHandler = ActiveConnectionsStateless -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Conversation -> String -> String -> Messages -> IO () +type ConnectionHandler = ActiveConnectionsStateless -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> Conversation -> String -> String -> Messages -> IO () type Conversation = ConversationStateless @@ -104,7 +104,7 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do MVar.putMVar socketsmvar updatedMap return newsocket where - createServer :: ActiveConnectionsStateless -> ConnectionHandler -> Int -> VChanConnections -> IO (MVar.MVar [(String, Syntax.Type)]) + createServer :: ActiveConnectionsStateless -> ConnectionHandler -> Int -> VChanConnections -> IO (MVar.MVar [(String, (Syntax.Type, Syntax.Type))]) createServer activeCons connectionhandler port vchanconnections = do -- serverid <- UserID.newRandomUserID sock <- socket AF_INET Stream 0 @@ -123,7 +123,7 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do MVar.putMVar clientlist [] forkIO $ acceptClients activeCons connectionhandler vchanconnections clientlist sock $ show port return clientlist - acceptClients :: ActiveConnectionsStateless -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> Socket -> String -> IO () + acceptClients :: ActiveConnectionsStateless -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> Socket -> String -> IO () acceptClients activeCons connectionhandler mvar clientlist socket ownport = do Config.traceIO "Waiting for clients" clientsocket <- accept socket @@ -132,7 +132,7 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do forkIO $ acceptClient activeCons connectionhandler mvar clientlist clientsocket ownport acceptClients activeCons connectionhandler mvar clientlist socket ownport - acceptClient :: ActiveConnectionsStateless -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> String -> IO () + acceptClient :: ActiveConnectionsStateless -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> String -> IO () acceptClient activeCons connectionhandler mvar clientlist clientsocket ownport = do hdl <- getSocketFromHandle $ fst clientsocket let conv = (hdl, clientsocket) diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index c62c191..6c31daa 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -47,7 +47,7 @@ instance Serializable Responses where instance Serializable Messages where serialize = \case - IntroduceClient p port t -> serializeLabeledEntryMulti "NIntroduceClient" p $ sNext port $ sLast t + IntroduceClient p port tn t -> serializeLabeledEntryMulti "NIntroduceClient" p $ sNext port $ sNext tn $ sLast t NewValue p c v -> serializeLabeledEntryMulti "NNewValue" p $ sNext c $ sLast v SyncIncoming p vs -> serializeLabeledEntryMulti "NSyncIncoming" p $ sLast vs RequestSync p count -> serializeLabeledEntryMulti "NRequestSync" p $ sLast count diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index f5a2767..825e689 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -35,7 +35,7 @@ import Control.Monad import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC import qualified Control.Concurrent.SSem as SSem -handleClient :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> Messages -> IO () +handleClient :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> Messages -> IO () handleClient activeCons mvar clientlist clientsocket hdl ownport message deserialmessages = do let userid = getUserID deserialmessages netcon <- MVar.readMVar mvar @@ -52,13 +52,15 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria busy <- SSem.tryWait $ ncHandlingIncomingMessage networkcon case busy of Just num -> do + Config.traceNetIO "Not busy handling message!" redirectRequest <- checkAndSendRedirectRequest hdl netcon userid - unless redirectRequest $ + unless redirectRequest $ do + Config.traceNetIO "No redirect request!" case deserialmessages of NewValue userid count val -> do handleNewValue activeCons mvar userid count val ownport clientHostaddress hdl - IntroduceClient userid clientport syntype-> do - handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype + IntroduceClient userid clientport synname syntype-> do + handleIntroduceClient mvar clientlist clientsocket hdl userid clientport (syntype, syntype) RequestSync userid count -> do handleRequestSync mvar userid count hdl SyncIncoming userid values -> do @@ -89,12 +91,12 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria Nothing -> do Config.traceNetIO "Recieved message from unknown connection!" case deserialmessages of - IntroduceClient userid clientport syntype-> do - handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype + IntroduceClient userid clientport synname syntype-> do + handleIntroduceClient mvar clientlist clientsocket hdl userid clientport (synname, syntype) _ -> do serial <- NSerialize.serialize deserialmessages - Config.traceIO $ "Error unsupported networkmessage: "++ serial - Config.traceIO "This is probably a timing issue! Lets resend later" + Config.traceNetIO $ " Error unsupported networkmessage: "++ serial + Config.traceNetIO " This is probably a timing issue! Lets resend later" NC.sendResponse hdl Messages.Wait Config.traceNetIO $ " Message: " ++ message @@ -209,7 +211,7 @@ contactNewPeers activeCons input ownport = case input of -- return $ (fst x, newval):rest return () -handleIntroduceClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> Syntax.Type -> IO () +handleIntroduceClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> (Syntax.Type, Syntax.Type) -> IO () handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype = do networkconnectionmap <- MVar.takeMVar mvar case Map.lookup userid networkconnectionmap of @@ -269,7 +271,7 @@ hostaddressTypeToString hostaddress = do let (a, b, c, d) = hostAddressToTuple hostaddress show a ++ "." ++ show b ++ "."++ show c ++ "." ++ show d -findFittingClientMaybe :: MVar.MVar [(String, Syntax.Type)] -> Syntax.Type -> IO (Maybe String) +findFittingClientMaybe :: MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Syntax.Type, Syntax.Type) -> IO (Maybe String) findFittingClientMaybe clientlist desiredType = do clientlistraw <- MVar.takeMVar clientlist let newclientlistrawAndReturn = fFCMRaw clientlistraw desiredType @@ -277,14 +279,17 @@ findFittingClientMaybe clientlist desiredType = do MVar.putMVar clientlist $ fst newclientlistrawAndReturn return $ snd newclientlistrawAndReturn where - fFCMRaw :: [(String, Syntax.Type)] -> Syntax.Type -> ([(String, Syntax.Type)], Maybe String) + fFCMRaw :: [(String, (Syntax.Type, Syntax.Type))] -> (Syntax.Type, Syntax.Type) -> ([(String, (Syntax.Type, Syntax.Type))], Maybe String) fFCMRaw [] _ = ([], Nothing) - fFCMRaw (x:xs) desiredtype = if snd x == Syntax.dualof desiredtype then (xs, Just $ fst x) else do + fFCMRaw (x:xs) desiredtype = if compare (snd x) desiredtype then (xs, Just $ fst x) else do let nextfFCMRaw = fFCMRaw xs desiredtype (x:(fst nextfFCMRaw), snd nextfFCMRaw) + + compare :: (Syntax.Type, Syntax.Type) -> (Syntax.Type, Syntax.Type) -> Bool + compare a@(aName, aType) b@(bName, bType) = aName == Syntax.dualof bName && aType == bType -- This halts until a fitting client is found -findFittingClient :: MVar.MVar [(String, Syntax.Type)] -> Syntax.Type -> IO String +findFittingClient :: MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Syntax.Type, Syntax.Type) -> IO String findFittingClient clientlist desiredType = do mbystring <- findFittingClientMaybe clientlist desiredType case mbystring of diff --git a/src/ProcessEnvironmentTypes.hs b/src/ProcessEnvironmentTypes.hs index 670b0d6..0454e3d 100644 --- a/src/ProcessEnvironmentTypes.hs +++ b/src/ProcessEnvironmentTypes.hs @@ -40,7 +40,7 @@ instance Show FuncType where -- data NetworkAddress = NetworkAddress {hostname :: String, port :: String} -- deriving (Eq, Show) -type ServerSocket = (MVar.MVar [(String, Type)], String) +type ServerSocket = (MVar.MVar [(String, (Type, Type))], String) type VChanConnections = MVar.MVar (Map.Map String (NCon.NetworkConnection Value)) diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 6682e7f..cf0a8eb 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -279,7 +279,7 @@ GType : gunit {GUnit} | gdouble {GDouble} | gstring {GString} -Messages : nintroduceclient '(' String ')' '(' String ')' '(' Type ')' {IntroduceClient $3 $6 $9} +Messages : nintroduceclient '(' String ')' '(' String ')' '(' Type ')' '(' Type ')' {IntroduceClient $3 $6 $9 $12} | nnewvalue '(' String ')' '(' int ')' '(' Values ')' {NewValue $3 $6 $9} | nsyncincoming '(' String ')''(' SValuesArray ')' {SyncIncoming $3 $6} | nrequestsync '(' String ')' '(' int ')' {RequestSync $3 $6} From 34874a5fa672e5cb054f2722643d4b9555442072 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Fri, 10 Feb 2023 14:35:52 +0100 Subject: [PATCH 122/229] Improved message handling still buggy --- src/Networking/NetworkConnection.hs | 8 ++ src/Networking/Server.hs | 196 +++++++++++++++++++++++++++- 2 files changed, 202 insertions(+), 2 deletions(-) diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index d607051..5ef5de8 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -8,6 +8,7 @@ import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.SSem as SSem data NetworkConnection a = NetworkConnection {ncRead :: DirectionalConnection a, ncWrite :: DirectionalConnection a, ncPartnerUserID :: Maybe String, ncOwnUserID :: Maybe String, ncConnectionState :: MVar.MVar ConnectionState, ncHandlingIncomingMessage :: SSem.SSem} + | NetworkConnectionPlaceholder {ncPartnerUserID :: Maybe String, ncConnectionState :: MVar.MVar ConnectionState} deriving Eq data ConnectionState = Connected {csHostname :: String, csPort :: String} @@ -16,6 +17,11 @@ data ConnectionState = Connected {csHostname :: String, csPort :: String} | RedirectRequest {csHostname :: String, csPort :: String, csRedirectHostname :: String, csRedirectPort :: String} -- Asks to redirect to this connection deriving (Eq, Show) +newPlaceHolderConnection :: String -> String -> String -> IO (NetworkConnection a) +newPlaceHolderConnection partnerID hostname port = do + connectionstate <- MVar.newMVar $ Connected hostname port + return $ NetworkConnectionPlaceholder (Just partnerID) connectionstate + newNetworkConnection :: String -> String -> String -> String -> IO (NetworkConnection a) newNetworkConnection partnerID ownID hostname port = do @@ -89,5 +95,7 @@ serializeNetworkConnection nc = do changePartnerAddress :: NetworkConnection a -> String -> String -> IO () changePartnerAddress con hostname port = do + putStrLn "Tryping to take MVar" _ <- MVar.takeMVar $ ncConnectionState con + putStrLn "Took MVar" MVar.putMVar (ncConnectionState con) $ Connected hostname port \ No newline at end of file diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 825e689..3ed9287 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -35,6 +35,7 @@ import Control.Monad import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC import qualified Control.Concurrent.SSem as SSem +{- handleClient :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> Messages -> IO () handleClient activeCons mvar clientlist clientsocket hdl ownport message deserialmessages = do let userid = getUserID deserialmessages @@ -99,13 +100,202 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria Config.traceNetIO " This is probably a timing issue! Lets resend later" NC.sendResponse hdl Messages.Wait Config.traceNetIO $ " Message: " ++ message - - +-} checkAndSendRedirectRequest :: NC.ConversationOrHandle -> Map.Map String (NetworkConnection Value) -> String -> IO Bool checkAndSendRedirectRequest handle ncmap userid = do case Map.lookup userid ncmap of Nothing -> return False + + +handleClient :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> Messages -> IO () +handleClient activeCons mvar clientlist clientsocket hdl ownport message deserialmessages = do + let userid = getUserID deserialmessages + clientHostaddress <- case snd clientsocket of + SockAddrInet _ hostname -> return $ hostaddressTypeToString hostname + _ -> do + Config.traceIO "Error during recieving a networkmessage: only ipv4 is currently supported!" + return "" + + netcons <- MVar.readMVar mvar + newnetcon <- case Map.lookup userid netcons of + Just networkcon -> do + Config.traceNetIO $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " (" ++ ownport ++ ") from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) + Config.traceNetIO $ " "++message + busy <- SSem.tryWait $ ncHandlingIncomingMessage networkcon + case busy of + Just num -> do + constate <- MVar.readMVar $ ncConnectionState networkcon + reply <- case constate of + RedirectRequest _ _ host port -> do + Config.traceNetIO $ "Found redirect request for: " ++ userid + Config.traceNetIO $ "Send redirect to:" ++ host ++ ":" ++ port + NC.sendResponse hdl (Messages.Redirect host port) + return Nothing + Connected {} -> do + case networkcon of + NetworkConnection dc dc' m_s m_str mv ss -> case deserialmessages of + NewValue userid count val -> do + ND.lockInterpreterReads (ncRead networkcon) + success <- ND.writeMessageIfNext (ncRead networkcon) count val + incomingCount <- ND.countMessages (ncRead networkcon) + unless success $ NC.sendNetworkMessage activeCons networkcon (Messages.RequestSync (Data.Maybe.fromMaybe "" (ncOwnUserID networkcon)) incomingCount) (-1) + contactNewPeers activeCons val ownport + NC.sendResponse hdl Messages.Okay + ND.unlockInterpreterReads (ncRead networkcon) + return Nothing + IntroduceNewPartnerAddress userid port -> do + Config.traceNetIO $ "Trying to change the address to: " ++ clientHostaddress ++ ":" ++ port + NCon.changePartnerAddress networkcon clientHostaddress port + NC.sendResponse hdl Messages.Okay + return Nothing + RequestSync userid count -> do + writevals <- ND.allMessages $ ncWrite networkcon + if length writevals > count then NC.sendResponse hdl (Messages.OkaySync writevals) else NC.sendResponse hdl Messages.Okay + return Nothing + _ -> do + serial <- NSerialize.serialize deserialmessages + Config.traceIO $ "Error unsupported networkmessage: "++ serial + NC.sendResponse hdl Messages.Okay + return Nothing + NetworkConnectionPlaceholder m_s mv -> do + Config.traceNetIO "Recieved message to placeholder! Send wait response" + NC.sendResponse hdl Messages.Wait + return Nothing + _ -> do + Config.traceNetIO "Network Connection is in a illegal state!" + return Nothing + SSem.signal $ ncHandlingIncomingMessage networkcon + return reply + Nothing -> do + Config.traceNetIO "Message cannot be handled at the moment! Sending wait response" + NC.sendResponse hdl Messages.Wait + return Nothing + + Nothing -> do + Config.traceNetIO "Recieved message from unknown connection!" + case deserialmessages of + IntroduceClient userid clientport synname syntype -> do + serverid <- UserID.newRandomUserID + newpeer <- newNetworkConnection userid serverid clientHostaddress clientport + NC.sendResponse hdl (Messages.OkayIntroduce serverid) + repserial <- NSerialize.serialize $ Messages.OkayIntroduce serverid + Config.traceNetIO $ " Response to "++ userid ++ ": " ++ repserial + + clientlistraw <- MVar.takeMVar clientlist + MVar.putMVar clientlist $ clientlistraw ++ [(userid, (synname, syntype))] + + return $ Just newpeer + IntroduceNewPartnerAddress userid port -> do + placeholder <- NCon.newPlaceHolderConnection userid clientHostaddress port + return $ Just placeholder + _ -> do + serial <- NSerialize.serialize deserialmessages + Config.traceNetIO $ " Error unsupported networkmessage: "++ serial + Config.traceNetIO " This is probably a timing issue! Lets resend later" + NC.sendResponse hdl Messages.Wait + return Nothing + + Config.traceNetIO "Patching MVar" + case newnetcon of + Just newnet -> do + netcons <- MVar.takeMVar mvar + MVar.putMVar mvar $ Map.insert userid newnet netcons + Nothing -> return () + Config.traceNetIO "Message successfully recieved" + + + +{-handleClient :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> Messages -> IO () +handleClient activeCons mvar clientlist clientsocket hdl ownport message deserialmessages = do + let userid = getUserID deserialmessages + clientHostaddress <- case snd clientsocket of + SockAddrInet _ hostname -> return $ hostaddressTypeToString hostname + _ -> do + Config.traceIO "Error during recieving a networkmessage: only ipv4 is currently supported!" + return "" + + netcons <- MVar.readMVar mvar + newnetcon <- case Map.lookup userid netcons of + Just networkcon -> do + Config.traceNetIO $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " (" ++ ownport ++ ") from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) + Config.traceNetIO $ " "++message + busy <- SSem.tryWait $ ncHandlingIncomingMessage networkcon + case busy of + Just num -> do + constate <- MVar.readMVar $ ncConnectionState networkcon + case constate of + RedirectRequest _ _ host port -> do + Config.traceNetIO $ "Found redirect request for: " ++ userid + Config.traceNetIO $ "Send redirect to:" ++ host ++ ":" ++ port + NC.sendResponse hdl (Messages.Redirect host port) + return Nothing + Connected {} -> do + case networkcon of + NetworkConnection dc dc' m_s m_str mv ss -> case deserialmessages of + NewValue userid count val -> do + ND.lockInterpreterReads (ncRead networkcon) + success <- ND.writeMessageIfNext (ncRead networkcon) count val + incomingCount <- ND.countMessages (ncRead networkcon) + unless success $ NC.sendNetworkMessage activeCons networkcon (Messages.RequestSync (Data.Maybe.fromMaybe "" (ncOwnUserID networkcon)) incomingCount) (-1) + contactNewPeers activeCons val ownport + NC.sendResponse hdl Messages.Okay + ND.unlockInterpreterReads (ncRead networkcon) + return Nothing + IntroduceNewPartnerAddress userid port -> do + Config.traceNetIO $ "Trying to change the address to: " ++ clientHostaddress ++ ":" ++ port + NCon.changePartnerAddress networkcon clientHostaddress port + return Nothing + RequestSync userid count -> do + writevals <- ND.allMessages $ ncWrite networkcon + if length writevals > count then NC.sendResponse hdl (Messages.OkaySync writevals) else NC.sendResponse hdl Messages.Okay + return Nothing + _ -> do + serial <- NSerialize.serialize deserialmessages + Config.traceIO $ "Error unsupported networkmessage: "++ serial + NC.sendResponse hdl Messages.Okay + return Nothing + NetworkConnectionPlaceholder m_s mv -> do + Config.traceNetIO "Recieved message to placeholder! Send wait response" + NC.sendResponse hdl Messages.Wait + return Nothing + _ -> do + Config.traceNetIO "Network Connection is in a illegal state!" + return Nothing + Nothing -> do + Config.traceNetIO "Message cannot be handled at the moment! Sending wait response" + NC.sendResponse hdl Messages.Wait + return Nothing + + Nothing -> do + Config.traceNetIO "Recieved message from unknown connection!" + case deserialmessages of + IntroduceClient userid clientport synname syntype -> do + serverid <- UserID.newRandomUserID + newpeer <- newNetworkConnection userid serverid clientHostaddress clientport + NC.sendResponse hdl (Messages.OkayIntroduce serverid) + repserial <- NSerialize.serialize $ Messages.OkayIntroduce serverid + Config.traceNetIO $ " Response to "++ userid ++ ": " ++ repserial + + clientlistraw <- MVar.takeMVar clientlist + MVar.putMVar clientlist $ clientlistraw ++ [(userid, (synname, syntype))] + + return $ Just newpeer + IntroduceNewPartnerAddress userid port -> do + placeholder <- NCon.newPlaceHolderConnection userid clientHostaddress port + return $ Just placeholder + _ -> do + serial <- NSerialize.serialize deserialmessages + Config.traceNetIO $ " Error unsupported networkmessage: "++ serial + Config.traceNetIO " This is probably a timing issue! Lets resend later" + NC.sendResponse hdl Messages.Wait + return Nothing + case newnetcon of + Just newnet -> do + netcons <- MVar.takeMVar mvar + MVar.putMVar mvar $ Map.insert userid newnet netcons + Nothing -> return () + Just networkconnection -> do constate <- MVar.readMVar $ ncConnectionState networkconnection case constate of @@ -116,6 +306,8 @@ checkAndSendRedirectRequest handle ncmap userid = do return True _ -> return False + +-} handleNewValue :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> Int -> Value -> String -> String -> NC.ConversationOrHandle -> IO () handleNewValue activeCons mvar userid count rawval ownport partneraddress hdl = do -- networkconnectionmap <- MVar.takeMVar mvar From debeba8d18f324f049975b78a6dbb1cd9ac63fdc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sun, 12 Feb 2023 15:06:43 +0100 Subject: [PATCH 123/229] Better logging --- src/Networking/Client.hs | 8 ++--- src/Networking/DirectionalConnection.hs | 8 ++++- src/Networking/NetworkConnection.hs | 2 -- src/Networking/Server.hs | 42 +++++++++++++++---------- 4 files changed, 35 insertions(+), 25 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 1c5ab45..44809ba 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -50,10 +50,8 @@ sendValue vchanconsmvar activeCons networkconnection val ownport resendOnError = valcleaned <- replaceVChan val DC.writeMessage (ncWrite networkconnection) valcleaned messagesCount <- DC.countMessages $ ncWrite networkconnection - catch (do - tryToSendNetworkMessage activeCons networkconnection hostname port (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) messagesCount valcleaned) resendOnError - disableVChans val - ) $ printConErr hostname port + tryToSendNetworkMessage activeCons networkconnection hostname port (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) messagesCount valcleaned) resendOnError + disableVChans val NCon.Emulated -> do vchancons <- MVar.readMVar vchanconsmvar valCleaned <- replaceVChan val @@ -71,7 +69,7 @@ sendNetworkMessage activeCons networkconnection message resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port -> do - catch ( tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError) $ printConErr hostname port + tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError _ -> Config.traceNetIO "Error when sending message: This channel is disconnected" tryToSendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> String -> String -> Messages -> Int -> IO () diff --git a/src/Networking/DirectionalConnection.hs b/src/Networking/DirectionalConnection.hs index a905cb2..ebd0b4c 100644 --- a/src/Networking/DirectionalConnection.hs +++ b/src/Networking/DirectionalConnection.hs @@ -54,8 +54,14 @@ writeMessageIfNext connection count message = do -- This relies on the message array giving having the same first entrys as the internal messages syncMessages :: DirectionalConnection a -> [a] -> IO () syncMessages connection msgs = do + mymessagesCount <- takeMVar $ messagesCount connection mymessages <- takeMVar $ messages connection - if length mymessages < length msgs then putMVar (messages connection) msgs else putMVar (messages connection) mymessages + if length mymessages < length msgs then do + putMVar (messages connection) msgs + putMVar (messagesCount connection) $ length msgs + else do + putMVar (messages connection) mymessages + putMVar (messagesCount connection) mymessagesCount -- Gives all outMessages until this point allMessages :: DirectionalConnection a -> IO [a] diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index 5ef5de8..30ad90e 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -95,7 +95,5 @@ serializeNetworkConnection nc = do changePartnerAddress :: NetworkConnection a -> String -> String -> IO () changePartnerAddress con hostname port = do - putStrLn "Tryping to take MVar" _ <- MVar.takeMVar $ ncConnectionState con - putStrLn "Took MVar" MVar.putMVar (ncConnectionState con) $ Connected hostname port \ No newline at end of file diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 3ed9287..0223b50 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -114,22 +114,22 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria clientHostaddress <- case snd clientsocket of SockAddrInet _ hostname -> return $ hostaddressTypeToString hostname _ -> do - Config.traceIO "Error during recieving a networkmessage: only ipv4 is currently supported!" + recievedNetLog message "Error during recieving a networkmessage: only ipv4 is currently supported!" return "" netcons <- MVar.readMVar mvar newnetcon <- case Map.lookup userid netcons of Just networkcon -> do - Config.traceNetIO $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " (" ++ ownport ++ ") from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) - Config.traceNetIO $ " "++message + recievedNetLog message $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " (" ++ ownport ++ ") from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) + -- Config.traceNetIO $ " "++message busy <- SSem.tryWait $ ncHandlingIncomingMessage networkcon case busy of Just num -> do constate <- MVar.readMVar $ ncConnectionState networkcon reply <- case constate of RedirectRequest _ _ host port -> do - Config.traceNetIO $ "Found redirect request for: " ++ userid - Config.traceNetIO $ "Send redirect to:" ++ host ++ ":" ++ port + recievedNetLog message $ "Found redirect request for: " ++ userid + recievedNetLog message $ "Send redirect to:" ++ host ++ ":" ++ port NC.sendResponse hdl (Messages.Redirect host port) return Nothing Connected {} -> do @@ -145,7 +145,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria ND.unlockInterpreterReads (ncRead networkcon) return Nothing IntroduceNewPartnerAddress userid port -> do - Config.traceNetIO $ "Trying to change the address to: " ++ clientHostaddress ++ ":" ++ port + recievedNetLog message $ "Trying to change the address to: " ++ clientHostaddress ++ ":" ++ port NCon.changePartnerAddress networkcon clientHostaddress port NC.sendResponse hdl Messages.Okay return Nothing @@ -155,32 +155,32 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria return Nothing _ -> do serial <- NSerialize.serialize deserialmessages - Config.traceIO $ "Error unsupported networkmessage: "++ serial + recievedNetLog message $ "Error unsupported networkmessage: "++ serial NC.sendResponse hdl Messages.Okay return Nothing NetworkConnectionPlaceholder m_s mv -> do - Config.traceNetIO "Recieved message to placeholder! Send wait response" + recievedNetLog message "Recieved message to placeholder! Send wait response" NC.sendResponse hdl Messages.Wait return Nothing _ -> do - Config.traceNetIO "Network Connection is in a illegal state!" + recievedNetLog message "Network Connection is in a illegal state!" return Nothing SSem.signal $ ncHandlingIncomingMessage networkcon return reply Nothing -> do - Config.traceNetIO "Message cannot be handled at the moment! Sending wait response" + recievedNetLog message "Message cannot be handled at the moment! Sending wait response" NC.sendResponse hdl Messages.Wait return Nothing Nothing -> do - Config.traceNetIO "Recieved message from unknown connection!" + recievedNetLog message "Recieved message from unknown connection" case deserialmessages of IntroduceClient userid clientport synname syntype -> do serverid <- UserID.newRandomUserID newpeer <- newNetworkConnection userid serverid clientHostaddress clientport NC.sendResponse hdl (Messages.OkayIntroduce serverid) repserial <- NSerialize.serialize $ Messages.OkayIntroduce serverid - Config.traceNetIO $ " Response to "++ userid ++ ": " ++ repserial + recievedNetLog message $ " Response to "++ userid ++ ": " ++ repserial clientlistraw <- MVar.takeMVar clientlist MVar.putMVar clientlist $ clientlistraw ++ [(userid, (synname, syntype))] @@ -191,20 +191,21 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria return $ Just placeholder _ -> do serial <- NSerialize.serialize deserialmessages - Config.traceNetIO $ " Error unsupported networkmessage: "++ serial - Config.traceNetIO " This is probably a timing issue! Lets resend later" + recievedNetLog message $ "Error unsupported networkmessage: "++ serial + recievedNetLog message "This is probably a timing issue! Lets resend later" NC.sendResponse hdl Messages.Wait return Nothing - Config.traceNetIO "Patching MVar" + recievedNetLog message "Patching MVar" case newnetcon of Just newnet -> do netcons <- MVar.takeMVar mvar MVar.putMVar mvar $ Map.insert userid newnet netcons Nothing -> return () - Config.traceNetIO "Message successfully recieved" - + recievedNetLog message "Message successfully handled" +recievedNetLog :: String -> String -> IO () +recievedNetLog msg info = Config.traceNetIO $ "Recieved message: "++msg++" \n Status: "++info {-handleClient :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> Messages -> IO () handleClient activeCons mvar clientlist clientsocket hdl ownport message deserialmessages = do @@ -517,6 +518,13 @@ replaceVChanSerial activeCons mvar input = case input of VChanSerial r w p o c -> do networkconnection <- createNetworkConnectionS r w p o c ncmap <- MVar.takeMVar mvar + case Map.lookup p ncmap of + Just networkcon -> do + connectionState <- MVar.readMVar $ ncConnectionState networkcon + MVar.takeMVar $ ncConnectionState networkconnection + MVar.putMVar (ncConnectionState networkconnection) connectionState + Nothing -> return () + MVar.putMVar mvar $ Map.insert p networkconnection ncmap NClient.sendNetworkMessage activeCons networkconnection (RequestSync o $ length r) 5 used<- MVar.newEmptyMVar From 04093a7f15650423d5da5d2191f193e622d76d59 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sun, 12 Feb 2023 15:16:30 +0100 Subject: [PATCH 124/229] Update Server.hs --- src/Networking/Server.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 0223b50..75c581f 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -138,10 +138,15 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria NewValue userid count val -> do ND.lockInterpreterReads (ncRead networkcon) success <- ND.writeMessageIfNext (ncRead networkcon) count val - incomingCount <- ND.countMessages (ncRead networkcon) - unless success $ NC.sendNetworkMessage activeCons networkcon (Messages.RequestSync (Data.Maybe.fromMaybe "" (ncOwnUserID networkcon)) incomingCount) (-1) + recievedNetLog message $ if success then "Message written successfully" else "Message out of sync" + unless success $ do + incomingCount <- ND.countMessages (ncRead networkcon) + NC.sendNetworkMessage activeCons networkcon (Messages.RequestSync (Data.Maybe.fromMaybe "" (ncOwnUserID networkcon)) incomingCount) (-1) + recievedNetLog message "Send sync request" contactNewPeers activeCons val ownport + recievedNetLog message "Messaged peers" NC.sendResponse hdl Messages.Okay + recievedNetLog message "Sent okay" ND.unlockInterpreterReads (ncRead networkcon) return Nothing IntroduceNewPartnerAddress userid port -> do From f0e15ced5818be5f56eb4f316af8d79a8fc335d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sun, 12 Feb 2023 16:55:04 +0100 Subject: [PATCH 125/229] Made the semaphore less strict - stateless networking reenabled --- src/Networking/Common.hs | 4 ++-- src/Networking/NetworkConnection.hs | 5 +++-- .../NetworkingMethod/NetworkingMethodCommon.hs | 4 ++-- src/Networking/Server.hs | 17 +++++++++++++++-- 4 files changed, 22 insertions(+), 8 deletions(-) diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 2b79c1e..d0bc64a 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -9,8 +9,8 @@ import qualified Networking.Serialize as NSerialize import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG import qualified Config --- import qualified Networking.NetworkingMethod.Stateless as NetMethod -import qualified Networking.NetworkingMethod.Fast as NetMethod +import qualified Networking.NetworkingMethod.Stateless as NetMethod +-- import qualified Networking.NetworkingMethod.Fast as NetMethod type ConversationOrHandle = NetMethod.Conversation diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index 30ad90e..5d6be87 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -8,7 +8,7 @@ import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.SSem as SSem data NetworkConnection a = NetworkConnection {ncRead :: DirectionalConnection a, ncWrite :: DirectionalConnection a, ncPartnerUserID :: Maybe String, ncOwnUserID :: Maybe String, ncConnectionState :: MVar.MVar ConnectionState, ncHandlingIncomingMessage :: SSem.SSem} - | NetworkConnectionPlaceholder {ncPartnerUserID :: Maybe String, ncConnectionState :: MVar.MVar ConnectionState} + | NetworkConnectionPlaceholder {ncPartnerUserID :: Maybe String, ncConnectionState :: MVar.MVar ConnectionState, ncHandlingIncomingMessage :: SSem.SSem} deriving Eq data ConnectionState = Connected {csHostname :: String, csPort :: String} @@ -20,7 +20,8 @@ data ConnectionState = Connected {csHostname :: String, csPort :: String} newPlaceHolderConnection :: String -> String -> String -> IO (NetworkConnection a) newPlaceHolderConnection partnerID hostname port = do connectionstate <- MVar.newMVar $ Connected hostname port - return $ NetworkConnectionPlaceholder (Just partnerID) connectionstate + incomingMsg <- SSem.new 1 + return $ NetworkConnectionPlaceholder (Just partnerID) connectionstate incomingMsg newNetworkConnection :: String -> String -> String -> String -> IO (NetworkConnection a) diff --git a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs index 1ba20be..4b27bb2 100644 --- a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs +++ b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs @@ -8,9 +8,9 @@ import Networking.Messages import qualified Control.Concurrent.SSem as SSem import Network.Socket --- type ActiveConnections = ActiveConnectionsStateless +type ActiveConnections = ActiveConnectionsStateless -type ActiveConnections = ActiveConnectionsFast +-- type ActiveConnections = ActiveConnectionsFast data ActiveConnectionsStateless = ActiveConnectionsStateless diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 75c581f..beed577 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -1,4 +1,6 @@ {-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Redundant return" #-} module Networking.Server where import qualified Control.Concurrent.MVar as MVar @@ -131,6 +133,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria recievedNetLog message $ "Found redirect request for: " ++ userid recievedNetLog message $ "Send redirect to:" ++ host ++ ":" ++ port NC.sendResponse hdl (Messages.Redirect host port) + SSem.signal $ ncHandlingIncomingMessage networkcon return Nothing Connected {} -> do case networkcon of @@ -138,11 +141,14 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria NewValue userid count val -> do ND.lockInterpreterReads (ncRead networkcon) success <- ND.writeMessageIfNext (ncRead networkcon) count val + SSem.signal $ ncHandlingIncomingMessage networkcon recievedNetLog message $ if success then "Message written successfully" else "Message out of sync" unless success $ do incomingCount <- ND.countMessages (ncRead networkcon) NC.sendNetworkMessage activeCons networkcon (Messages.RequestSync (Data.Maybe.fromMaybe "" (ncOwnUserID networkcon)) incomingCount) (-1) recievedNetLog message "Send sync request" + + -- This can deadlock contactNewPeers activeCons val ownport recievedNetLog message "Messaged peers" NC.sendResponse hdl Messages.Okay @@ -152,28 +158,35 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria IntroduceNewPartnerAddress userid port -> do recievedNetLog message $ "Trying to change the address to: " ++ clientHostaddress ++ ":" ++ port NCon.changePartnerAddress networkcon clientHostaddress port + SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Okay return Nothing RequestSync userid count -> do writevals <- ND.allMessages $ ncWrite networkcon if length writevals > count then NC.sendResponse hdl (Messages.OkaySync writevals) else NC.sendResponse hdl Messages.Okay + SSem.signal $ ncHandlingIncomingMessage networkcon return Nothing _ -> do serial <- NSerialize.serialize deserialmessages recievedNetLog message $ "Error unsupported networkmessage: "++ serial + SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Okay return Nothing - NetworkConnectionPlaceholder m_s mv -> do + NetworkConnectionPlaceholder m_s mv ss -> do recievedNetLog message "Recieved message to placeholder! Send wait response" + SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Wait return Nothing _ -> do recievedNetLog message "Network Connection is in a illegal state!" + SSem.signal $ ncHandlingIncomingMessage networkcon + NC.sendResponse hdl Messages.Okay return Nothing - SSem.signal $ ncHandlingIncomingMessage networkcon + -- SSem.signal $ ncHandlingIncomingMessage networkcon return reply Nothing -> do recievedNetLog message "Message cannot be handled at the moment! Sending wait response" + SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Wait return Nothing From 8d5df99a8aff20125e446cf2e130bb88890ceef0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sun, 12 Feb 2023 18:37:43 +0100 Subject: [PATCH 126/229] More logging --- src/Networking/Client.hs | 51 ++++++++++++------- src/Networking/Common.hs | 4 +- src/Networking/NetworkingMethod/Fast.hs | 22 ++++---- .../NetworkingMethodCommon.hs | 4 +- src/Networking/NetworkingMethod/Stateless.hs | 9 ++-- 5 files changed, 54 insertions(+), 36 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 44809ba..c287252 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -75,59 +75,76 @@ sendNetworkMessage activeCons networkconnection message resendOnError = do tryToSendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> String -> String -> Messages -> Int -> IO () tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError = do serializedMessage <- NSerialize.serialize message - Config.traceNetIO $ "Sending message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection) ++ " to: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkconnection) - Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port - Config.traceNetIO $ " Message: " ++ serializedMessage + --Config.traceNetIO $ "Sending message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection) ++ " to: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkconnection) + --Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port + --Config.traceNetIO $ " Message: " ++ serializedMessage + sendingNetLog serializedMessage $ "Sending message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection) ++ " to: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkconnection) ++ " Over: " ++ hostname ++ ":" ++ port mbycon <- NC.startConversation activeCons hostname port 10000 10 mbyresponse <- case mbycon of Just con -> do + sendingNetLog serializedMessage "Aquired connection" NC.sendMessage con message - potentialResponse <- NC.recieveResponse con 10000 100 + sendingNetLog serializedMessage "Sent message" + potentialResponse <- NC.recieveResponse con 10000 1000 + sendingNetLog serializedMessage "Recieved response" NC.endConversation con 10000 10 + sendingNetLog serializedMessage "Ended connection" return potentialResponse - Nothing -> return Nothing + Nothing -> do + sendingNetLog serializedMessage "Connecting unsuccessful" + return Nothing case mbyresponse of Just response -> case response of - Okay -> Config.traceNetIO $ "Message okay: "++serializedMessage + Okay -> sendingNetLog serializedMessage "Message okay" -- Config.traceNetIO $ "Message okay: "++serializedMessage OkaySync historyraw -> do -- let history = map (setPartnerHostAddress historyraw -- let history = historyraw let history = map (setPartnerHostAddress $ NC.getPartnerHostaddress $ Data.Maybe.fromJust mbycon) historyraw - Config.traceNetIO $ "Message okay: "++serializedMessage + --Config.traceNetIO $ "Message okay: "++serializedMessage serializedResponse <- NSerialize.serialize response - Config.traceNetIO $ "Got syncronization values: "++serializedResponse + -- Config.traceNetIO $ "Got syncronization values: "++serializedResponse DC.syncMessages (ncRead networkconnection) history + sendingNetLog serializedMessage $ "Message okay; Got syncronization values: "++serializedResponse Redirect host port -> do - Config.traceNetIO "Communication partner changed address, resending" + sendingNetLog serializedMessage "Communication partner changed address, resending" NCon.changePartnerAddress networkconnection host port tryToSendNetworkMessage activeCons networkconnection host port message resendOnError Wait -> do - Config.traceNetIO "Communication out of sync lets wait!" + sendingNetLog serializedMessage "Communication out of sync lets wait!" threadDelay 100000 tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError - _ -> Config.traceNetIO "Unknown communication error" + _ -> sendingNetLog serializedMessage "Unknown communication error" Nothing -> do - Config.traceNetIO "Error when recieving response" + sendingNetLog serializedMessage "Error when recieving response" connectionstate <- MVar.readMVar $ ncConnectionState networkconnection - when (Data.Maybe.isNothing mbycon) $ Config.traceNetIO "Not connected to peer" - Config.traceNetIO $ "Original message: " ++ serializedMessage + when (Data.Maybe.isNothing mbycon) $ sendingNetLog serializedMessage "Not connected to peer" + -- Config.traceNetIO $ "Original message: " ++ serializedMessage case connectionstate of NCon.Connected newhostname newport -> do + {- isClosed <- case mbycon of Just con -> NC.isClosed con Nothing -> return True if resendOnError /= 0 && not isClosed then do - Config.traceNetIO $ "Connected but no answer recieved! New communication partner: " ++ newhostname ++ ":" ++ newport + sendingNetLog serializedMessage $ "Connected but no answer recieved! New communication partner: " ++ newhostname ++ ":" ++ newport threadDelay 50000 tryToSendNetworkMessage activeCons networkconnection newhostname newport message $ max (resendOnError-1) (-1) - else Config.traceNetIO "Old communication partner offline! No longer retrying" + else sendingNetLog serializedMessage "Old communication partner offline! No longer retrying" + -} + sendingNetLog serializedMessage $ "Connected but no answer recieved! New communication partner: " ++ newhostname ++ ":" ++ newport + threadDelay 500000 + tryToSendNetworkMessage activeCons networkconnection newhostname newport message $ max (resendOnError-1) (-1) - _ -> Config.traceNetIO "Error when sending message: This channel is disconnected while sending" + _ -> sendingNetLog serializedMessage "Error when sending message: This channel is disconnected while sending" + sendingNetLog serializedMessage "Message got send or finally failed!" +sendingNetLog :: String -> String -> IO () +sendingNetLog msg info = Config.traceNetIO $ "Sending message: "++msg++" \n Status: "++info + setPartnerHostAddress :: String -> Value -> Value setPartnerHostAddress address input = case input of VSend v -> VSend $ setPartnerHostAddress address v diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index d0bc64a..2b79c1e 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -9,8 +9,8 @@ import qualified Networking.Serialize as NSerialize import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG import qualified Config -import qualified Networking.NetworkingMethod.Stateless as NetMethod --- import qualified Networking.NetworkingMethod.Fast as NetMethod +-- import qualified Networking.NetworkingMethod.Stateless as NetMethod +import qualified Networking.NetworkingMethod.Fast as NetMethod type ConversationOrHandle = NetMethod.Conversation diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index d3d82f3..48f27b2 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -54,16 +54,16 @@ conversationHandlerChangeHandle handle chan mvar sem = do isClosed <- MVar.newEmptyMVar MVar.putMVar isClosed False forkIO $ whileNotMVar isClosed (do - -- Config.traceNetIO "Waiting for new conversation" + Config.traceNetIO "Waiting for new conversation" Stateless.recieveMessageInternal handle VG.parseConversation (\_ -> return ()) (\mes des -> do - -- Config.traceNetIO "Got new conversation" + Config.traceNetIO $ "Got new conversation: " ++ mes case des of ConversationMessage cid message -> Chan.writeChan chan (cid, (mes, message)) ConversationResponse cid response -> do - -- Config.traceNetIO "Trying to take mvar" + Config.traceNetIO "Trying to take mvar" mymap <- MVar.takeMVar mvar MVar.putMVar mvar $ Map.insert cid (mes, response) mymap - -- Config.traceNetIO "Set responses mvar" + Config.traceNetIO "Set responses mvar" ConversationCloseAll -> do Config.traceNetIO $ "Recieved Message: " ++ mes MVar.takeMVar isClosed @@ -89,18 +89,18 @@ conversationHandlerChangeHandle handle chan mvar sem = do recieveResponse :: Conversation -> Int -> Int -> IO (Maybe Responses) -recieveResponse conv{-ersation@(cid, handle, mvar, sem)-} waitTime tries = do +recieveResponse conv waitTime tries = do -- Config.traceNetIO "Trying to take mvar for responses mvar" - responsesMap <- MVar.takeMVar $ convRespMap conv + responsesMap <- MVar.readMVar $ convRespMap conv -- Config.traceNetIO "Got MVar for responses" case Map.lookup (convID conv) responsesMap of Just (messages, deserial) -> do - MVar.putMVar (convRespMap conv) $ Map.delete (convID conv) responsesMap + -- MVar.putMVar (convRespMap conv) $ Map.delete (convID conv) responsesMap return $ Just deserial Nothing -> do - MVar.putMVar (convRespMap conv) responsesMap - handleClosed <- hIsClosed $ fst (convHandle conv) - if tries /= 0 && not handleClosed then do + -- MVar.putMVar (convRespMap conv) responsesMap + -- handleClosed <- hIsClosed $ fst (convHandle conv) + if tries /= 0 {-&& not handleClosed-} then do -- Config.traceNetIO "Nothing yet retrying!" threadDelay waitTime recieveResponse conv waitTime $ max (tries-1) (-1) else return Nothing @@ -203,7 +203,7 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do acceptClient :: ActiveConnectionsFast -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> String -> IO () acceptClient activeCons connectionhandler mvar clientlist clientsocket ownport = do - hdl <- Stateless.getSocketFromHandle $ fst clientsocket + hdl <- Stateless.getHandleFromSocket $ fst clientsocket let statelessConv = (hdl, clientsocket) connection@(handle, isClosed, chan, responsesMvar, sem) <- conversationHandler statelessConv -- NC.recieveMessage hdl VG.parseMessages (\_ -> return ()) $ connectionhandler mvar clientlist clientsocket hdl ownport diff --git a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs index 4b27bb2..1ba20be 100644 --- a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs +++ b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs @@ -8,9 +8,9 @@ import Networking.Messages import qualified Control.Concurrent.SSem as SSem import Network.Socket -type ActiveConnections = ActiveConnectionsStateless +-- type ActiveConnections = ActiveConnectionsStateless --- type ActiveConnections = ActiveConnectionsFast +type ActiveConnections = ActiveConnectionsFast data ActiveConnectionsStateless = ActiveConnectionsStateless diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index 0389114..2bd69dd 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -71,8 +71,9 @@ startConversation _ hostname port waitTime tries = do addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port clientsocket <- openSocketNC $ head addrInfo connect clientsocket $ addrAddress $ head addrInfo - handle <- getSocketFromHandle clientsocket + handle <- getHandleFromSocket clientsocket MVar.putMVar convMVar (handle, (clientsocket, addrAddress $ head addrInfo)) + Config.traceNetIO $ "Connected to: " ++ hostname ++ ":"++port ) $ printConErr hostname port getFromNetworkThread Nothing threadid convMVar waitTime tries @@ -134,7 +135,7 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do acceptClient :: ActiveConnectionsStateless -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> String -> IO () acceptClient activeCons connectionhandler mvar clientlist clientsocket ownport = do - hdl <- getSocketFromHandle $ fst clientsocket + hdl <- getHandleFromSocket $ fst clientsocket let conv = (hdl, clientsocket) recieveMessageInternal conv VG.parseMessages (\_ -> return ()) $ connectionhandler activeCons mvar clientlist clientsocket conv ownport hClose hdl @@ -182,8 +183,8 @@ createActiveConnections = return ActiveConnectionsStateless openSocketNC :: AddrInfo -> IO Socket openSocketNC addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) -getSocketFromHandle :: Socket -> IO Handle -getSocketFromHandle socket = do +getHandleFromSocket :: Socket -> IO Handle +getHandleFromSocket socket = do hdl <- socketToHandle socket ReadWriteMode -- hSetBuffering hdl NoBuffering hSetBuffering hdl LineBuffering From 0cf1a709d769ccd2305da3bb06eb6c80ea2b1bfe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sun, 12 Feb 2023 18:42:43 +0100 Subject: [PATCH 127/229] Removed hIsClosed as it is a dangerous command --- src/Networking/Common.hs | 2 -- src/Networking/NetworkingMethod/Fast.hs | 9 +++++---- src/Networking/NetworkingMethod/Stateless.hs | 8 ++++---- 3 files changed, 9 insertions(+), 10 deletions(-) diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 2b79c1e..a475269 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -36,8 +36,6 @@ endConversation con waitTime tries = NetMethod.endConversation con waitTime trie sayGoodbye con = NetMethod.sayGoodbye con -isClosed con = NetMethod.isClosed con - getPartnerHostaddress conv = NetMethod.getPartnerHostaddress conv diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index 48f27b2..f61e52c 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -69,8 +69,9 @@ conversationHandlerChangeHandle handle chan mvar sem = do MVar.takeMVar isClosed MVar.putMVar isClosed True forkIO $ catch (do - closed <- hIsClosed $ fst handle - unless closed $ hClose $ fst handle) onException + -- closed <- hIsClosed $ fst handle + -- unless closed $ + hClose $ fst handle) onException return () ) ) @@ -242,8 +243,8 @@ sayGoodbye activeCons = do onException _ = return () -isClosed :: Conversation -> IO Bool -isClosed = hIsClosed . fst . convHandle +{-isClosed :: Conversation -> IO Bool +isClosed = hIsClosed . fst . convHandle-} getPartnerHostaddress :: Conversation -> String getPartnerHostaddress = Stateless.getPartnerHostaddress . convHandle diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index 2bd69dd..aa81e6e 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -151,8 +151,8 @@ getFromNetworkThreadWithModification conv func threadid mvar waitTime currentTry case mbyResult of Just result -> return $ func result Nothing -> do - convClosed <- Data.Maybe.maybe (return False) (hIsClosed . fst) conv - if currentTry /= 0 && not convClosed then do + -- convClosed <- Data.Maybe.maybe (return False) (hIsClosed . fst) conv + if currentTry /= 0 {-&& not convClosed-} then do threadDelay waitTime getFromNetworkThreadWithModification conv func threadid mvar waitTime $ max (currentTry-1) (-1) else do @@ -193,8 +193,8 @@ getHandleFromSocket socket = do sayGoodbye :: ActiveConnectionsStateless -> IO () sayGoodbye _ = return () -isClosed :: Conversation -> IO Bool -isClosed = hIsClosed . fst +{-isClosed :: Conversation -> IO Bool +isClosed = hIsClosed . fst-} hostaddressTypeToString :: HostAddress -> String hostaddressTypeToString hostaddress = do From 8a6b7b6b07a392b5af451085bd43d15f371a1c02 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 13 Feb 2023 10:41:26 +0100 Subject: [PATCH 128/229] Last commit before rewriting again --- src/Networking/Client.hs | 2 +- src/Networking/NetworkConnection.hs | 5 +- src/Networking/Server.hs | 252 +--------------------------- 3 files changed, 9 insertions(+), 250 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index c287252..cef0451 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -113,7 +113,7 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen tryToSendNetworkMessage activeCons networkconnection host port message resendOnError Wait -> do sendingNetLog serializedMessage "Communication out of sync lets wait!" - threadDelay 100000 + threadDelay 1000000 tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError _ -> sendingNetLog serializedMessage "Unknown communication error" diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index 5d6be87..1f0b098 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -8,7 +8,7 @@ import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.SSem as SSem data NetworkConnection a = NetworkConnection {ncRead :: DirectionalConnection a, ncWrite :: DirectionalConnection a, ncPartnerUserID :: Maybe String, ncOwnUserID :: Maybe String, ncConnectionState :: MVar.MVar ConnectionState, ncHandlingIncomingMessage :: SSem.SSem} - | NetworkConnectionPlaceholder {ncPartnerUserID :: Maybe String, ncConnectionState :: MVar.MVar ConnectionState, ncHandlingIncomingMessage :: SSem.SSem} + | NetworkConnectionPlaceholder {ncPartnerUserID :: Maybe String, ncOwnUserID :: Maybe String, ncConnectionState :: MVar.MVar ConnectionState, ncHandlingIncomingMessage :: SSem.SSem} deriving Eq data ConnectionState = Connected {csHostname :: String, csPort :: String} @@ -21,7 +21,8 @@ newPlaceHolderConnection :: String -> String -> String -> IO (NetworkConnection newPlaceHolderConnection partnerID hostname port = do connectionstate <- MVar.newMVar $ Connected hostname port incomingMsg <- SSem.new 1 - return $ NetworkConnectionPlaceholder (Just partnerID) connectionstate incomingMsg + -- The own userid is simply needed to make it compatible with preexisting code, A placeholder can only save the address of a partnerID though. + return $ NetworkConnectionPlaceholder (Just partnerID) Nothing connectionstate incomingMsg newNetworkConnection :: String -> String -> String -> String -> IO (NetworkConnection a) diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index beed577..5010812 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -37,73 +37,6 @@ import Control.Monad import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC import qualified Control.Concurrent.SSem as SSem -{- -handleClient :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> Messages -> IO () -handleClient activeCons mvar clientlist clientsocket hdl ownport message deserialmessages = do - let userid = getUserID deserialmessages - netcon <- MVar.readMVar mvar - - clientHostaddress <- case snd clientsocket of - SockAddrInet _ hostname -> return $ hostaddressTypeToString hostname - _ -> return "" - - -- MVar.putMVar mvar netcon - case Map.lookup userid netcon of - Just networkcon -> do -- SSem.withSem (ncHandlingIncomingMessage networkcon) $ do - Config.traceNetIO $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " (" ++ ownport ++ ") from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) - Config.traceNetIO $ " "++message - busy <- SSem.tryWait $ ncHandlingIncomingMessage networkcon - case busy of - Just num -> do - Config.traceNetIO "Not busy handling message!" - redirectRequest <- checkAndSendRedirectRequest hdl netcon userid - unless redirectRequest $ do - Config.traceNetIO "No redirect request!" - case deserialmessages of - NewValue userid count val -> do - handleNewValue activeCons mvar userid count val ownport clientHostaddress hdl - IntroduceClient userid clientport synname syntype-> do - handleIntroduceClient mvar clientlist clientsocket hdl userid clientport (syntype, syntype) - RequestSync userid count -> do - handleRequestSync mvar userid count hdl - SyncIncoming userid values -> do - handleSyncIncoming mvar userid values - NC.sendResponse hdl Messages.Okay - IntroduceNewPartnerAddress userid port -> do - networkconnectionmap <- MVar.takeMVar mvar - Config.traceNetIO $ "Took MVar for message: " ++ message - case Map.lookup userid networkconnectionmap of - Just networkconnection -> do -- Change to current network address - case snd clientsocket of - SockAddrInet _ hostname -> do - Config.traceNetIO $ "Trying to change the address to: " ++ hostaddressTypeToString hostname ++ ":" ++ port - NCon.changePartnerAddress networkconnection (hostaddressTypeToString hostname) port - _ -> return () - Config.traceNetIO $ "Put MVar for message: " ++ message - MVar.putMVar mvar networkconnectionmap - Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that - NC.sendResponse hdl Messages.Okay - _ -> do - serial <- NSerialize.serialize deserialmessages - Config.traceIO $ "Error unsupported networkmessage: "++ serial - NC.sendResponse hdl Messages.Okay - SSem.signal $ ncHandlingIncomingMessage networkcon - Nothing -> do - Config.traceNetIO "Message cannot be handled at the moment! Sending wait response" - NC.sendResponse hdl Messages.Wait - Nothing -> do - Config.traceNetIO "Recieved message from unknown connection!" - case deserialmessages of - IntroduceClient userid clientport synname syntype-> do - handleIntroduceClient mvar clientlist clientsocket hdl userid clientport (synname, syntype) - _ -> do - serial <- NSerialize.serialize deserialmessages - Config.traceNetIO $ " Error unsupported networkmessage: "++ serial - Config.traceNetIO " This is probably a timing issue! Lets resend later" - NC.sendResponse hdl Messages.Wait - Config.traceNetIO $ " Message: " ++ message --} - checkAndSendRedirectRequest :: NC.ConversationOrHandle -> Map.Map String (NetworkConnection Value) -> String -> IO Bool checkAndSendRedirectRequest handle ncmap userid = do case Map.lookup userid ncmap of @@ -132,12 +65,12 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria RedirectRequest _ _ host port -> do recievedNetLog message $ "Found redirect request for: " ++ userid recievedNetLog message $ "Send redirect to:" ++ host ++ ":" ++ port - NC.sendResponse hdl (Messages.Redirect host port) SSem.signal $ ncHandlingIncomingMessage networkcon + NC.sendResponse hdl (Messages.Redirect host port) return Nothing Connected {} -> do case networkcon of - NetworkConnection dc dc' m_s m_str mv ss -> case deserialmessages of + NetworkConnection {} -> case deserialmessages of NewValue userid count val -> do ND.lockInterpreterReads (ncRead networkcon) success <- ND.writeMessageIfNext (ncRead networkcon) count val @@ -149,6 +82,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria recievedNetLog message "Send sync request" -- This can deadlock + -- Todo add an timeout to this function and randomize the waittime uppon a wait command contactNewPeers activeCons val ownport recievedNetLog message "Messaged peers" NC.sendResponse hdl Messages.Okay @@ -163,8 +97,8 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria return Nothing RequestSync userid count -> do writevals <- ND.allMessages $ ncWrite networkcon - if length writevals > count then NC.sendResponse hdl (Messages.OkaySync writevals) else NC.sendResponse hdl Messages.Okay SSem.signal $ ncHandlingIncomingMessage networkcon + if length writevals > count then NC.sendResponse hdl (Messages.OkaySync writevals) else NC.sendResponse hdl Messages.Okay return Nothing _ -> do serial <- NSerialize.serialize deserialmessages @@ -172,7 +106,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Okay return Nothing - NetworkConnectionPlaceholder m_s mv ss -> do + NetworkConnectionPlaceholder {} -> do recievedNetLog message "Recieved message to placeholder! Send wait response" SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Wait @@ -225,127 +159,6 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria recievedNetLog :: String -> String -> IO () recievedNetLog msg info = Config.traceNetIO $ "Recieved message: "++msg++" \n Status: "++info -{-handleClient :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> Messages -> IO () -handleClient activeCons mvar clientlist clientsocket hdl ownport message deserialmessages = do - let userid = getUserID deserialmessages - clientHostaddress <- case snd clientsocket of - SockAddrInet _ hostname -> return $ hostaddressTypeToString hostname - _ -> do - Config.traceIO "Error during recieving a networkmessage: only ipv4 is currently supported!" - return "" - - netcons <- MVar.readMVar mvar - newnetcon <- case Map.lookup userid netcons of - Just networkcon -> do - Config.traceNetIO $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " (" ++ ownport ++ ") from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) - Config.traceNetIO $ " "++message - busy <- SSem.tryWait $ ncHandlingIncomingMessage networkcon - case busy of - Just num -> do - constate <- MVar.readMVar $ ncConnectionState networkcon - case constate of - RedirectRequest _ _ host port -> do - Config.traceNetIO $ "Found redirect request for: " ++ userid - Config.traceNetIO $ "Send redirect to:" ++ host ++ ":" ++ port - NC.sendResponse hdl (Messages.Redirect host port) - return Nothing - Connected {} -> do - case networkcon of - NetworkConnection dc dc' m_s m_str mv ss -> case deserialmessages of - NewValue userid count val -> do - ND.lockInterpreterReads (ncRead networkcon) - success <- ND.writeMessageIfNext (ncRead networkcon) count val - incomingCount <- ND.countMessages (ncRead networkcon) - unless success $ NC.sendNetworkMessage activeCons networkcon (Messages.RequestSync (Data.Maybe.fromMaybe "" (ncOwnUserID networkcon)) incomingCount) (-1) - contactNewPeers activeCons val ownport - NC.sendResponse hdl Messages.Okay - ND.unlockInterpreterReads (ncRead networkcon) - return Nothing - IntroduceNewPartnerAddress userid port -> do - Config.traceNetIO $ "Trying to change the address to: " ++ clientHostaddress ++ ":" ++ port - NCon.changePartnerAddress networkcon clientHostaddress port - return Nothing - RequestSync userid count -> do - writevals <- ND.allMessages $ ncWrite networkcon - if length writevals > count then NC.sendResponse hdl (Messages.OkaySync writevals) else NC.sendResponse hdl Messages.Okay - return Nothing - _ -> do - serial <- NSerialize.serialize deserialmessages - Config.traceIO $ "Error unsupported networkmessage: "++ serial - NC.sendResponse hdl Messages.Okay - return Nothing - NetworkConnectionPlaceholder m_s mv -> do - Config.traceNetIO "Recieved message to placeholder! Send wait response" - NC.sendResponse hdl Messages.Wait - return Nothing - _ -> do - Config.traceNetIO "Network Connection is in a illegal state!" - return Nothing - Nothing -> do - Config.traceNetIO "Message cannot be handled at the moment! Sending wait response" - NC.sendResponse hdl Messages.Wait - return Nothing - - Nothing -> do - Config.traceNetIO "Recieved message from unknown connection!" - case deserialmessages of - IntroduceClient userid clientport synname syntype -> do - serverid <- UserID.newRandomUserID - newpeer <- newNetworkConnection userid serverid clientHostaddress clientport - NC.sendResponse hdl (Messages.OkayIntroduce serverid) - repserial <- NSerialize.serialize $ Messages.OkayIntroduce serverid - Config.traceNetIO $ " Response to "++ userid ++ ": " ++ repserial - - clientlistraw <- MVar.takeMVar clientlist - MVar.putMVar clientlist $ clientlistraw ++ [(userid, (synname, syntype))] - - return $ Just newpeer - IntroduceNewPartnerAddress userid port -> do - placeholder <- NCon.newPlaceHolderConnection userid clientHostaddress port - return $ Just placeholder - _ -> do - serial <- NSerialize.serialize deserialmessages - Config.traceNetIO $ " Error unsupported networkmessage: "++ serial - Config.traceNetIO " This is probably a timing issue! Lets resend later" - NC.sendResponse hdl Messages.Wait - return Nothing - case newnetcon of - Just newnet -> do - netcons <- MVar.takeMVar mvar - MVar.putMVar mvar $ Map.insert userid newnet netcons - Nothing -> return () - - Just networkconnection -> do - constate <- MVar.readMVar $ ncConnectionState networkconnection - case constate of - RedirectRequest _ _ host port -> do - Config.traceNetIO $ "Found redirect request for: " ++ userid - Config.traceNetIO $ "Send redirect to:" ++ host ++ ":" ++ port - NC.sendResponse handle (Messages.Redirect host port) - return True - _ -> return False - - --} -handleNewValue :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> Int -> Value -> String -> String -> NC.ConversationOrHandle -> IO () -handleNewValue activeCons mvar userid count rawval ownport partneraddress hdl = do - -- networkconnectionmap <- MVar.takeMVar mvar - let val = setPartnerHostAddress partneraddress rawval - networkconnectionmap <- MVar.readMVar mvar - case Map.lookup userid networkconnectionmap of - Just networkconnection -> do - ND.lockInterpreterReads (ncRead networkconnection) - success <- ND.writeMessageIfNext (ncRead networkconnection) count val - incomingCount <- ND.countMessages (ncRead networkconnection) - unless success $ NC.sendNetworkMessage activeCons networkconnection (Messages.RequestSync (Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) incomingCount) (-1) - contactNewPeers activeCons val ownport - NC.sendResponse hdl Messages.Okay - ND.unlockInterpreterReads (ncRead networkconnection) - Nothing -> do - NC.sendResponse hdl Messages.Okay - Config.traceNetIO "Error during recieving a networkmessage: Introduction is needed prior to sending values!" - -- MVar.putMVar mvar networkconnectionmap - setPartnerHostAddress :: String -> Value -> Value setPartnerHostAddress address input = case input of @@ -422,61 +235,6 @@ contactNewPeers activeCons input ownport = case input of -- return $ (fst x, newval):rest return () -handleIntroduceClient :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> (Syntax.Type, Syntax.Type) -> IO () -handleIntroduceClient mvar clientlist clientsocket hdl userid clientport syntype = do - networkconnectionmap <- MVar.takeMVar mvar - case Map.lookup userid networkconnectionmap of - Just networkconnection -> do - Config.traceIO "Error during recieving a networkmessage: Already introduced to this client!" - MVar.putMVar mvar networkconnectionmap - Nothing -> case snd clientsocket of -- This client is new - SockAddrInet port hostname -> do - serverid <- UserID.newRandomUserID - networkconnection <- newNetworkConnection userid serverid (hostaddressTypeToString hostname) clientport - let newnetworkconnectionmap = Map.insert userid networkconnection networkconnectionmap - MVar.putMVar mvar newnetworkconnectionmap - NC.sendResponse hdl (Messages.OkayIntroduce serverid) - repserial <- NSerialize.serialize $ Messages.OkayIntroduce serverid - Config.traceNetIO $ " Response to "++ userid ++ ": " ++ repserial - -- Adds the new user to the users that can be accepted by the server - clientlistraw <- MVar.takeMVar clientlist - MVar.putMVar clientlist $ clientlistraw ++ [(userid, syntype)] - - _ -> do - Config.traceIO "Error during recieving a networkmessage: only ipv4 is currently supported!" - MVar.putMVar mvar networkconnectionmap - NC.sendResponse hdl Messages.Okay - -handleChangePartnerAddress :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> String -> IO () -handleChangePartnerAddress activeCons mvar userid hostname port ownport = do - networkconnectionmap <- MVar.takeMVar mvar - case Map.lookup userid networkconnectionmap of - Just networkconnection -> do -- Change to current network address - NCon.changePartnerAddress networkconnection hostname port - -- For some reason constate doesn't seem to properly apply - - NClient.sendNetworkMessage activeCons networkconnection (Messages.IntroduceNewPartnerAddress (Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) ownport) 5 - MVar.putMVar mvar networkconnectionmap - - Nothing -> MVar.putMVar mvar networkconnectionmap -- Nothing needs to be done here, the connection hasn't been established yet. No need to save that - -handleRequestSync :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> Int -> NC.ConversationOrHandle -> IO () -handleRequestSync mvar userid count hdl = do - networkconnectionmap <- MVar.readMVar mvar - case Map.lookup userid networkconnectionmap of - Just networkconnection -> do -- Change to current network address - writevals <- ND.allMessages $ ncWrite networkconnection - if length writevals > count then NC.sendResponse hdl (Messages.OkaySync writevals) else NC.sendResponse hdl Messages.Okay - othing -> return () - -handleSyncIncoming :: MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> [Value] -> IO () -handleSyncIncoming mvar userid values = do - networkconnectionmap <- MVar.readMVar mvar - case Map.lookup userid networkconnectionmap of - Just networkconnection -> do -- Change to current network address - ND.syncMessages (ncRead networkconnection) values - Nothing -> return () - hostaddressTypeToString :: HostAddress -> String hostaddressTypeToString hostaddress = do let (a, b, c, d) = hostAddressToTuple hostaddress From d44eb5b7fedd7b8ddfadc8155482e7dfdd17572f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 13 Feb 2023 13:35:42 +0100 Subject: [PATCH 129/229] First code for new implementation --- src/Networking/Client.hs | 34 +------- src/Networking/DirectionalConnection.hs | 38 ++++++--- src/Networking/Messages.hs | 32 ++++--- src/Networking/NetworkConnection.hs | 106 ++++++++++++------------ src/Networking/Serialize.hs | 14 ++-- src/Networking/Server.hs | 90 ++++++++++---------- src/ValueParsing/ValueGrammar.y | 60 ++++++++------ src/ValueParsing/ValueTokens.x | 28 ++++--- 8 files changed, 204 insertions(+), 198 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index cef0451..a505c23 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -75,9 +75,6 @@ sendNetworkMessage activeCons networkconnection message resendOnError = do tryToSendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> String -> String -> Messages -> Int -> IO () tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError = do serializedMessage <- NSerialize.serialize message - --Config.traceNetIO $ "Sending message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection) ++ " to: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkconnection) - --Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port - --Config.traceNetIO $ " Message: " ++ serializedMessage sendingNetLog serializedMessage $ "Sending message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection) ++ " to: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkconnection) ++ " Over: " ++ hostname ++ ":" ++ port mbycon <- NC.startConversation activeCons hostname port 10000 10 @@ -97,16 +94,7 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen case mbyresponse of Just response -> case response of - Okay -> sendingNetLog serializedMessage "Message okay" -- Config.traceNetIO $ "Message okay: "++serializedMessage - OkaySync historyraw -> do - -- let history = map (setPartnerHostAddress historyraw - -- let history = historyraw - let history = map (setPartnerHostAddress $ NC.getPartnerHostaddress $ Data.Maybe.fromJust mbycon) historyraw - --Config.traceNetIO $ "Message okay: "++serializedMessage - serializedResponse <- NSerialize.serialize response - -- Config.traceNetIO $ "Got syncronization values: "++serializedResponse - DC.syncMessages (ncRead networkconnection) history - sendingNetLog serializedMessage $ "Message okay; Got syncronization values: "++serializedResponse + Okay -> sendingNetLog serializedMessage "Message okay" Redirect host port -> do sendingNetLog serializedMessage "Communication partner changed address, resending" NCon.changePartnerAddress networkconnection host port @@ -119,26 +107,6 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen Nothing -> do sendingNetLog serializedMessage "Error when recieving response" - connectionstate <- MVar.readMVar $ ncConnectionState networkconnection - when (Data.Maybe.isNothing mbycon) $ sendingNetLog serializedMessage "Not connected to peer" - -- Config.traceNetIO $ "Original message: " ++ serializedMessage - case connectionstate of - NCon.Connected newhostname newport -> do - {- - isClosed <- case mbycon of - Just con -> NC.isClosed con - Nothing -> return True - if resendOnError /= 0 && not isClosed then do - sendingNetLog serializedMessage $ "Connected but no answer recieved! New communication partner: " ++ newhostname ++ ":" ++ newport - threadDelay 50000 - tryToSendNetworkMessage activeCons networkconnection newhostname newport message $ max (resendOnError-1) (-1) - else sendingNetLog serializedMessage "Old communication partner offline! No longer retrying" - -} - sendingNetLog serializedMessage $ "Connected but no answer recieved! New communication partner: " ++ newhostname ++ ":" ++ newport - threadDelay 500000 - tryToSendNetworkMessage activeCons networkconnection newhostname newport message $ max (resendOnError-1) (-1) - - _ -> sendingNetLog serializedMessage "Error when sending message: This channel is disconnected while sending" sendingNetLog serializedMessage "Message got send or finally failed!" diff --git a/src/Networking/DirectionalConnection.hs b/src/Networking/DirectionalConnection.hs index ebd0b4c..cb3953a 100644 --- a/src/Networking/DirectionalConnection.hs +++ b/src/Networking/DirectionalConnection.hs @@ -13,9 +13,9 @@ newConnection :: IO (DirectionalConnection a) newConnection = do messages <- newEmptyMVar putMVar messages [] - messagesUnreadStart <- newEmptyMVar + messagesUnreadStart <- newEmptyMVar putMVar messagesUnreadStart 0 - messagesCount <- newEmptyMVar + messagesCount <- newEmptyMVar putMVar messagesCount 0 readLock <- SSem.new 1 return $ DirectionalConnection messages messagesUnreadStart messagesCount readLock @@ -25,9 +25,9 @@ createConnection :: [a] -> Int -> IO (DirectionalConnection a) createConnection messages unreadStart = do msg <- newEmptyMVar putMVar msg messages - messagesUnreadStart <- newEmptyMVar + messagesUnreadStart <- newEmptyMVar putMVar messagesUnreadStart unreadStart - messagesCount <- newEmptyMVar + messagesCount <- newEmptyMVar putMVar messagesCount $ length messages readLock <- SSem.new 1 return $ DirectionalConnection msg messagesUnreadStart messagesCount readLock @@ -43,23 +43,23 @@ writeMessage connection message = do writeMessageIfNext :: DirectionalConnection a -> Int -> a -> IO Bool writeMessageIfNext connection count message = do modifyMVar (messagesCount connection) (\c -> - if count == c + 1 then do + if count == c + 1 then do modifyMVar_ (messages connection) (\m -> return $ m ++ [message]) - return (c + 1, True) - else + return (c + 1, True) + else return (c, False) ) - + -- This relies on the message array giving having the same first entrys as the internal messages syncMessages :: DirectionalConnection a -> [a] -> IO () syncMessages connection msgs = do mymessagesCount <- takeMVar $ messagesCount connection mymessages <- takeMVar $ messages connection - if length mymessages < length msgs then do + if length mymessages < length msgs then do putMVar (messages connection) msgs putMVar (messagesCount connection) $ length msgs - else do + else do putMVar (messages connection) mymessages putMVar (messagesCount connection) mymessagesCount @@ -72,16 +72,28 @@ readUnreadMessageMaybe connection = modifyMVar (messagesUnreadStart connection) messagesBind <- allMessages connection if length messagesBind == i then return (i, Nothing) else return ((i+1), Just (messagesBind!!i)) ) - + readUnreadMessage :: DirectionalConnection a -> IO a readUnreadMessage connection = do maybeval <- readUnreadMessageMaybe connection case maybeval of - Nothing -> do + Nothing -> do threadDelay 5000 readUnreadMessage connection Just val -> return val +readMessageMaybe :: DirectionalConnection a -> Int -> IO (Maybe a) +readMessageMaybe connection index = do + msgList <- readMVar $ messages connection + if length msgList > index then return $ Just $ msgList !! index else return Nothing + +setUnreadCount :: DirectionalConnection a -> Int -> IO () +setUnreadCount connection index = do + msgLength <- readMVar $ messagesCount connection + when (msgLength > index) $ do + unreadLength <- takeMVar $ messagesUnreadStart connection + if index > unreadLength then putMVar (messagesUnreadStart connection) index else putMVar (messagesUnreadStart connection) unreadLength + readUnreadMessageInterpreter :: DirectionalConnection a -> IO a readUnreadMessageInterpreter connection = do -- debugExists <- System.Directory.doesFileExist "print.me" @@ -92,7 +104,7 @@ readUnreadMessageInterpreter connection = do -- currentRead <- readMVar $ messagesUnreadStart connection -- when debugExists $ putStrLn $ "DC: "++ show currentRead++" out of "++show allVals case maybeval of - Nothing -> do + Nothing -> do threadDelay 5000 readUnreadMessageInterpreter connection Just val -> return val diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs index 673e273..1573646 100644 --- a/src/Networking/Messages.hs +++ b/src/Networking/Messages.hs @@ -9,31 +9,39 @@ type UserID = String type Hostname = String type Port = String type ConversationID = String +type ConnectionID = String -data Messages +data Message = IntroduceClient UserID Port Type Type | NewValue UserID Int Value - | SyncIncoming UserID [Value] - | RequestSync UserID Int - | IntroduceNewPartnerAddress UserID Port + | RequestValue UserID Int + | AcknowledgeValue UserID Int + | NewPartnerAddress UserID Port ConnectionID + | AcknowledgePartnerAddress UserID ConnectionID + | Disconnect UserID + | AcknowledgeDisconnect UserID -- Vielleicht brauchen wir das nicht mal sehen deriving Eq -data Responses +data Response = Redirect Hostname Port | Okay | OkayIntroduce UserID - | OkaySync [Value] | Wait + | Error data ConversationSession - = ConversationMessage ConversationID Messages - | ConversationResponse ConversationID Responses + = ConversationMessage ConversationID Message + | ConversationResponse ConversationID Response | ConversationCloseAll -getUserID :: Messages -> String + +getUserID :: Message -> String getUserID = \case IntroduceClient p _ _ _ -> p NewValue p _ _ -> p - SyncIncoming p _ -> p - RequestSync p _ -> p - IntroduceNewPartnerAddress p _ -> p \ No newline at end of file + RequestValue p _ -> p + AcknowledgeValue p _ -> p + NewPartnerAddress p _ _ -> p + AcknowledgePartnerAddress p _ -> p + Disconnect p -> p + AcknowledgeDisconnect p -> p diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index 1f0b098..c9dd475 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -8,59 +8,33 @@ import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.SSem as SSem data NetworkConnection a = NetworkConnection {ncRead :: DirectionalConnection a, ncWrite :: DirectionalConnection a, ncPartnerUserID :: Maybe String, ncOwnUserID :: Maybe String, ncConnectionState :: MVar.MVar ConnectionState, ncHandlingIncomingMessage :: SSem.SSem} - | NetworkConnectionPlaceholder {ncPartnerUserID :: Maybe String, ncOwnUserID :: Maybe String, ncConnectionState :: MVar.MVar ConnectionState, ncHandlingIncomingMessage :: SSem.SSem} deriving Eq -data ConnectionState = Connected {csHostname :: String, csPort :: String} - | Disconnected - | Emulated - | RedirectRequest {csHostname :: String, csPort :: String, csRedirectHostname :: String, csRedirectPort :: String} -- Asks to redirect to this connection +data ConnectionState = Connected {csHostname :: String, csPort :: String, csPartnerConnectionID :: String, csOwnConnectionID :: String, csConfirmedConnection :: Bool} + | Disconnected {csPartnerConnectionID :: String, csOwnConnectionID :: String, csConfirmedConnection :: Bool} + | Emulated {csPartnerConnectionID :: String, csOwnConnectionID :: String, csConfirmedConnection :: Bool} + | RedirectRequest {csHostname :: String, csPort :: String, csRedirectHostname :: String, csRedirectPort :: String, csPartnerConnectionID :: String, csOwnConnectionID :: String, csConfirmedConnection :: Bool} -- Asks to redirect to this connection deriving (Eq, Show) -newPlaceHolderConnection :: String -> String -> String -> IO (NetworkConnection a) -newPlaceHolderConnection partnerID hostname port = do - connectionstate <- MVar.newMVar $ Connected hostname port - incomingMsg <- SSem.new 1 - -- The own userid is simply needed to make it compatible with preexisting code, A placeholder can only save the address of a partnerID though. - return $ NetworkConnectionPlaceholder (Just partnerID) Nothing connectionstate incomingMsg - -newNetworkConnection :: String -> String -> String -> String -> IO (NetworkConnection a) -newNetworkConnection partnerID ownID hostname port = do +newNetworkConnection :: String -> String -> String -> String -> String -> String -> IO (NetworkConnection a) +newNetworkConnection partnerID ownID hostname port partnerConnectionID ownConnectionID = do read <- newConnection write <- newConnection - connectionstate <- MVar.newMVar $ Connected hostname port + connectionstate <- MVar.newMVar $ Connected hostname port partnerConnectionID ownConnectionID True incomingMsg <- SSem.new 1 return $ NetworkConnection read write (Just partnerID) (Just ownID) connectionstate incomingMsg -newNetworkConnectionAllowingMaybe :: Maybe String -> Maybe String -> String -> String -> IO (NetworkConnection a) -newNetworkConnectionAllowingMaybe partnerID ownID hostname port = do - read <- newConnection - write <- newConnection - connectionstate <- MVar.newMVar $ Connected hostname port - incomingMsg <- SSem.new 1 - return $ NetworkConnection read write partnerID ownID connectionstate incomingMsg - -createNetworkConnection :: [a] -> Int -> [a] -> Int -> Maybe String -> Maybe String -> String -> String -> IO (NetworkConnection a) -createNetworkConnection readList readNew writeList writeNew partnerID ownID hostname port = do +createNetworkConnection :: ([a], Int) -> ([a], Int) -> String -> String -> (String, String, String) -> IO (NetworkConnection a) +createNetworkConnection (readList, readNew) (writeList, writeNew) partnerID ownID (hostname, port, partnerConnectionID) = do read <- createConnection readList readNew write <- createConnection writeList writeNew - connectionstate <- MVar.newMVar $ Connected hostname port + ownConnectionID <- newRandomUserID + connectionstate <- MVar.newMVar $ Connected hostname port partnerConnectionID ownConnectionID False incomingMsg <- SSem.new 1 - return $ NetworkConnection read write partnerID ownID connectionstate incomingMsg - - -createNetworkConnectionS :: ([a], Int) -> ([a], Int) -> String -> String -> (String, String) -> IO (NetworkConnection a) -createNetworkConnectionS (readList, readNew) (writeList, writeNew) partnerID ownID (hostname, port) = createNetworkConnection readList readNew writeList writeNew (Just partnerID) (Just ownID) hostname port - + return $ NetworkConnection read write (Just partnerID) (Just ownID) connectionstate incomingMsg -{-newEmulatedConnection :: DirectionalConnection a -> DirectionalConnection a -> IO (NetworkConnection a) -newEmulatedConnection r w = do - connectionstate <- MVar.newEmptyMVar - MVar.putMVar connectionstate Emulated - incomingMsg <- SSem.new 1 - return $ NetworkConnection r w Nothing Nothing connectionstate incomingMsg-} newEmulatedConnection :: MVar.MVar (Map.Map String (NetworkConnection a)) -> IO (NetworkConnection a, NetworkConnection a) newEmulatedConnection mvar = do @@ -69,8 +43,10 @@ newEmulatedConnection mvar = do write <- newConnection read2 <- newConnection write2 <- newConnection - connectionstate <- MVar.newMVar Emulated - connectionstate2 <- MVar.newMVar Emulated + connectionid1 <- newRandomUserID + connectionid2 <- newRandomUserID + connectionstate <- MVar.newMVar $ Emulated connectionid2 connectionid1 True + connectionstate2 <- MVar.newMVar $ Emulated connectionid1 connectionid2 True userid <- newRandomUserID userid2 <- newRandomUserID incomingMsg <- SSem.new 1 @@ -84,18 +60,46 @@ newEmulatedConnection mvar = do -serializeNetworkConnection :: NetworkConnection a -> IO ([a], Int, [a], Int, String, String, String, String) +serializeNetworkConnection :: NetworkConnection a -> IO ([a], Int, [a], Int, String, String, String, String, String) serializeNetworkConnection nc = do constate <- MVar.readMVar $ ncConnectionState nc (readList, readUnread) <- serializeConnection $ ncRead nc (writeList, writeUnread) <- serializeConnection $ ncWrite nc - (address, port) <- case constate of - Connected address port -> return (address, port) - RedirectRequest address port _ _-> return (address, port) - _ -> return ("", "") - return (readList, readUnread, writeList, writeUnread, Data.Maybe.fromMaybe "" $ ncPartnerUserID nc, Data.Maybe.fromMaybe "" $ ncOwnUserID nc, address, port) - -changePartnerAddress :: NetworkConnection a -> String -> String -> IO () -changePartnerAddress con hostname port = do - _ <- MVar.takeMVar $ ncConnectionState con - MVar.putMVar (ncConnectionState con) $ Connected hostname port \ No newline at end of file + (address, port, partnerConnectionID) <- case constate of + Connected address port partnerConnectionID _ _ -> return (address, port, partnerConnectionID) + RedirectRequest address port _ _ partnerConnectionID _ _ -> return (address, port, partnerConnectionID) + _ -> return ("", "", csPartnerConnectionID constate) + return (readList, readUnread, writeList, writeUnread, Data.Maybe.fromMaybe "" $ ncPartnerUserID nc, Data.Maybe.fromMaybe "" $ ncOwnUserID nc, address, port, partnerConnectionID) + +changePartnerAddress :: NetworkConnection a -> String -> String -> String -> IO () +changePartnerAddress con hostname port partnerConnectionID = do + oldConnectionState <- MVar.takeMVar $ ncConnectionState con + MVar.putMVar (ncConnectionState con) $ Connected hostname port partnerConnectionID (csOwnConnectionID oldConnectionState) $ csConfirmedConnection oldConnectionState + +disconnectFromPartner :: NetworkConnection a -> IO () +disconnectFromPartner con = do + oldConnectionState <- MVar.takeMVar $ ncConnectionState con + MVar.putMVar (ncConnectionState con) $ Disconnected (csPartnerConnectionID oldConnectionState) (csOwnConnectionID oldConnectionState) True + +isConnectionConfirmed :: NetworkConnection a -> IO Bool +isConnectionConfirmed con = do + conState <- MVar.readMVar $ ncConnectionState con + return $ csConfirmedConnection conState + +confirmConnectionID :: NetworkConnection a -> String -> IO Bool +confirmConnectionID con ownConnectionID = do + conState <- MVar.takeMVar $ ncConnectionState con + if ownConnectionID == csOwnConnectionID conState then do + newConState <- case conState of + Connected host port part own conf -> return $ Connected host port part own True + Disconnected part own conf -> return $ Disconnected part own True + Emulated part own conf -> return $ Emulated part own True + RedirectRequest host port rehost report part own conf -> return $ RedirectRequest host port rehost report part own True + MVar.putMVar (ncConnectionState con) newConState + return True + else do + MVar.putMVar (ncConnectionState con) conState + return False + + + diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index 6c31daa..6ecdc73 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -37,21 +37,23 @@ instance Serializable ConversationSession where ConversationResponse c r -> serializeLabeledEntryMulti "NConversationResponse" c $ sLast r ConversationCloseAll -> return "NConversationCloseAll" -instance Serializable Responses where +instance Serializable Response where serialize = \case Redirect host port -> serializeLabeledEntryMulti "NRedirect" host $ sLast port Okay -> return "NOkay" OkayIntroduce u -> serializeLabeledEntry "NOkayIntroduce" u - OkaySync vs -> serializeLabeledEntry "NOkaySync" vs Wait -> return "NWait" -instance Serializable Messages where +instance Serializable Message where serialize = \case IntroduceClient p port tn t -> serializeLabeledEntryMulti "NIntroduceClient" p $ sNext port $ sNext tn $ sLast t NewValue p c v -> serializeLabeledEntryMulti "NNewValue" p $ sNext c $ sLast v - SyncIncoming p vs -> serializeLabeledEntryMulti "NSyncIncoming" p $ sLast vs - RequestSync p count -> serializeLabeledEntryMulti "NRequestSync" p $ sLast count - IntroduceNewPartnerAddress u p -> serializeLabeledEntryMulti "NIntroduceNewPartnerAddress" u $ sLast p + RequestValue p c -> serializeLabeledEntryMulti "NRequestValue" p $ sLast c + AcknowledgeValue p c -> serializeLabeledEntryMulti "NAcknowledgeValue" p $ sLast c + NewPartnerAddress p port conID -> serializeLabeledEntryMulti "NNewPartnerAddress" p $ sNext port $ sLast conID + AcknowledgePartnerAddress p conID -> serializeLabeledEntryMulti "NAcknowledgePartnerAddress" p $ sLast conID + Disconnect p -> serializeLabeledEntry "NDisconnect" p + AcknowledgeDisconnect p -> serializeLabeledEntry "NAcknowledgeDisconnect" p instance Serializable (NCon.NetworkConnection Value) where serialize con = do diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 5010812..c4ef2bf 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -36,6 +36,8 @@ import Control.Monad import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC import qualified Control.Concurrent.SSem as SSem +import qualified Networking.DirectionalConnection as DC +import qualified Networking.NetworkConnection as NCon checkAndSendRedirectRequest :: NC.ConversationOrHandle -> Map.Map String (NetworkConnection Value) -> String -> IO Bool checkAndSendRedirectRequest handle ncmap userid = do @@ -68,55 +70,53 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl (Messages.Redirect host port) return Nothing - Connected {} -> do - case networkcon of - NetworkConnection {} -> case deserialmessages of - NewValue userid count val -> do - ND.lockInterpreterReads (ncRead networkcon) - success <- ND.writeMessageIfNext (ncRead networkcon) count val - SSem.signal $ ncHandlingIncomingMessage networkcon - recievedNetLog message $ if success then "Message written successfully" else "Message out of sync" - unless success $ do - incomingCount <- ND.countMessages (ncRead networkcon) - NC.sendNetworkMessage activeCons networkcon (Messages.RequestSync (Data.Maybe.fromMaybe "" (ncOwnUserID networkcon)) incomingCount) (-1) - recievedNetLog message "Send sync request" - - -- This can deadlock - -- Todo add an timeout to this function and randomize the waittime uppon a wait command - contactNewPeers activeCons val ownport - recievedNetLog message "Messaged peers" - NC.sendResponse hdl Messages.Okay - recievedNetLog message "Sent okay" - ND.unlockInterpreterReads (ncRead networkcon) - return Nothing - IntroduceNewPartnerAddress userid port -> do - recievedNetLog message $ "Trying to change the address to: " ++ clientHostaddress ++ ":" ++ port - NCon.changePartnerAddress networkcon clientHostaddress port - SSem.signal $ ncHandlingIncomingMessage networkcon - NC.sendResponse hdl Messages.Okay - return Nothing - RequestSync userid count -> do - writevals <- ND.allMessages $ ncWrite networkcon - SSem.signal $ ncHandlingIncomingMessage networkcon - if length writevals > count then NC.sendResponse hdl (Messages.OkaySync writevals) else NC.sendResponse hdl Messages.Okay - return Nothing - _ -> do - serial <- NSerialize.serialize deserialmessages - recievedNetLog message $ "Error unsupported networkmessage: "++ serial - SSem.signal $ ncHandlingIncomingMessage networkcon - NC.sendResponse hdl Messages.Okay - return Nothing - NetworkConnectionPlaceholder {} -> do - recievedNetLog message "Recieved message to placeholder! Send wait response" - SSem.signal $ ncHandlingIncomingMessage networkcon - NC.sendResponse hdl Messages.Wait - return Nothing + Connected {} -> case deserialmessages of + NewValue userid count val -> do + ND.lockInterpreterReads (ncRead networkcon) + ND.writeMessageIfNext (ncRead networkcon) count val + SSem.signal $ ncHandlingIncomingMessage networkcon + recievedNetLog message "Message written to Channel" + NC.sendResponse hdl Messages.Okay + recievedNetLog message "Sent okay" + ND.unlockInterpreterReads (ncRead networkcon) + return Nothing + Requestvalue userid count -> do + SSem.signal $ ncHandlingIncomingMessage networkcon + NC.sendResponse hdl Messages.Okay + mbyval <- DC.readMessageMaybe $ NCon.ncWrite networkcon + Data.Maybe.maybe (return ()) (\val -> sendNetworkMessage activeCons networkcon (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkcon) count val) 0) mbyval + return Nothing + AcknowledgeValue userid count -> do + DC.setUnreadCount (NCon.ncWrite networkcon) count + SSem.signal $ ncHandlingIncomingMessage networkcon + NC.sendResponse hdl Messages.Okay + NewPartnerAddress userid port connectionID -> do + recievedNetLog message $ "Trying to change the address to: " ++ clientHostaddress ++ ":" ++ port + NCon.changePartnerAddress networkcon clientHostaddress port connectionID + SSem.signal $ ncHandlingIncomingMessage networkcon + NC.sendResponse hdl Messages.Okay + return Nothing + AcknowledgePartnerAddress userid connectionID -> do + conConfirmed <- NCon.confirmConnectionID networkcon connectionID + SSem.signal $ ncHandlingIncomingMessage networkcon + if conConfirmed then NC.sendResponse hdl Messages.Okay else NC.sendResponse hdl Messages.Error + return Nothing + Disconnect UserID -> do + NCon.disconnectFromPartner networkcon + SSem.signal $ ncHandlingIncomingMessage networkcon + NC.sendResponse hdl Messages.Okay + return Nothing + _ -> do + serial <- NSerialize.serialize deserialmessages + recievedNetLog message $ "Error unsupported networkmessage: "++ serial + SSem.signal $ ncHandlingIncomingMessage networkcon + NC.sendResponse hdl Messages.Okay + return Nothing _ -> do recievedNetLog message "Network Connection is in a illegal state!" SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Okay return Nothing - -- SSem.signal $ ncHandlingIncomingMessage networkcon return reply Nothing -> do recievedNetLog message "Message cannot be handled at the moment! Sending wait response" @@ -292,7 +292,7 @@ replaceVChanSerial activeCons mvar input = case input of newpenv <- replaceVChanSerialPEnv activeCons mvar penv return $ VNewNatRec newpenv a b c d e f g VChanSerial r w p o c -> do - networkconnection <- createNetworkConnectionS r w p o c + networkconnection <- createNetworkConnection r w p o c ncmap <- MVar.takeMVar mvar case Map.lookup p ncmap of Just networkcon -> do diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index cf0a8eb..f7328b2 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -21,9 +21,9 @@ import Networking.Messages --%name parseDecls Cmds --%name parseType Typ -%name parseValues Values -%name parseMessages Messages -%name parseResponses Responses +%name parseValues Value +%name parseMessages Message +%name parseResponses Response %name parseConversation ConversationSession -- %name parseSStringTypeElement SStringTypeElement -- %name parseSStringTypeElements SStringTypeElements @@ -117,15 +117,18 @@ import Networking.Messages nintroduceclient { T _ T.NIntroduceClient } nnewvalue { T _ T.NNewValue } - nsyncincoming { T _ T.NSyncIncoming } - nrequestsync { T _ T.NRequestSync } - nchangepartneraddress {T _ T.NChangePartnerAddress } - nintroducenewpartneraddress {T _ T.NIntroduceNewPartnerAddress} + nrequestsync { T _ T.NRequestSync } + nacknowledgevalue {T _ T.NAcknowledgeValue } + nnewpartneraddress {T _ T.NNewPartnerAddress } + nacknowledgepartneraddress {T _ T.NAcknowledgePartnerAddress } + ndisconnect {T _ T.NDisconnect} + nacknowledgedisconnect {T _ T.NAcknowledgeDisconnect} + nredirect { T _ T.NRedirect} nokay { T _ T.NOkay} nokayintroduce { T _ T.NOkayIntroduce } - nokaysync { T _ T.NOkaySync } - nwait { T _ T.NWait} + nwait { T _ T.NWait } + nerror { T _ T.NError } nconversationmessage { T _ T.NConversationMessage} nconversationresponse { T _ T.NConversationResponse} nconversationcloseall { T _ T.NConversationCloseAll } @@ -182,7 +185,7 @@ import Networking.Messages -- Values : {[]} -- | vunit { VUnit } -Values : vunit { VUnit } +Value : vunit { VUnit } | vlabel '(' String ')' {VLabel $3 } | vint '(' int ')' {VInt $3} | vdouble '(' double ')' {VDouble $3} @@ -190,12 +193,12 @@ Values : vunit { VUnit } -- | vchan '(' SValuesArray ')' '(' int ')' '(' SValuesArray ')' '(' int ')' '(' String ')' '(' String ')' '(' String ')' '(' String ')' {VChanSerial $3 $6 $9 $12 $15 $18 $21 $24 } | vchan '(' NetworkConnection ')' {$3} | vchanserial '(' SArrayIntElement ')' '(' SArrayIntElement ')' '(' String ')' '(' String ')' '(' SStringStringElement ')' {VChanSerial $3 $6 $9 $12 $15} - | vsend '(' Values ')' {VSend $3} - | vpair '(' Values ')' '(' Values ')' {VPair $3 $6} + | vsend '(' Value ')' {VSend $3} + | vpair '(' Value ')' '(' Value ')' {VPair $3 $6} | vtype '(' Type ')' {VType $3} | vfunc '(' PEnv ')' '(' String ')' '(' Exp ')' {VFunc $3 $6 $9} - | vdyncast '(' Values ')' '(' GType ')' {VDynCast $3 $6} - | vfunccast '(' Values ')' '(' SFuncType ')' '(' SFuncType ')' {VFuncCast $3 $6 $9} + | vdyncast '(' Value ')' '(' GType ')' {VDynCast $3 $6} + | vfunccast '(' Value ')' '(' SFuncType ')' '(' SFuncType ')' {VFuncCast $3 $6 $9} | vrec '(' PEnv ')' '(' String ')' '(' String ')' '(' Exp ')' '(' Exp ')' {VRec $3 $6 $9 $12 $15} | vnewnatrec '(' PEnv ')' '(' String ')' '(' String ')' '(' String ')' '(' Type ')' '(' Exp ')' '(' String ')' '(' Exp ')' {VNewNatRec $3 $6 $9 $12 $15 $18 $21 $24} @@ -279,24 +282,29 @@ GType : gunit {GUnit} | gdouble {GDouble} | gstring {GString} -Messages : nintroduceclient '(' String ')' '(' String ')' '(' Type ')' '(' Type ')' {IntroduceClient $3 $6 $9 $12} - | nnewvalue '(' String ')' '(' int ')' '(' Values ')' {NewValue $3 $6 $9} - | nsyncincoming '(' String ')''(' SValuesArray ')' {SyncIncoming $3 $6} - | nrequestsync '(' String ')' '(' int ')' {RequestSync $3 $6} - | nintroducenewpartneraddress '(' String ')' '(' String ')' {IntroduceNewPartnerAddress $3 $6} +Message : nintroduceclient '(' String ')' '(' String ')' '(' Type ')' '(' Type ')' {IntroduceClient $3 $6 $9 $12} + | nnewvalue '(' String ')' '(' int ')' '(' Value ')' {NewValue $3 $6 $9} + | nrequestvalue '(' String ')' '(' int ')' {RequestValue $3 $6} + | nacknowledgevalue '(' String ')' '(' int ')' {AcknowledgeValue $3 $6} + | nnewpartneraddress '(' String ')' '(' String ')' '(' String ')' {NewPartnerAddress $3 $6 $9} + | nacknowledgepartneraddress '(' String ')' '(' String ')' {AcknowledgePartnerAddress $3 $6} + | ndisconnect '(' String ')' {Disconnect $3} + | nacknowledgedisconnect '(' String ')' {AcknowledgeDisconnect $3} + + -Responses : nredirect '(' String ')' '(' String ')' {Redirect $3 $6} +Response : nredirect '(' String ')' '(' String ')' {Redirect $3 $6} | nokay {Okay} | nokayintroduce '(' String ')' {OkayIntroduce $3} - | nokaysync '(' SValuesArray ')' {OkaySync $3} | nwait {Wait} + | nerror {Error} -ConversationSession : nconversationmessage '(' String ')' '(' Messages ')' {ConversationMessage $3 $6} - | nconversationresponse '(' String ')' '(' Responses ')' {ConversationResponse $3 $6} +ConversationSession : nconversationmessage '(' String ')' '(' Message ')' {ConversationMessage $3 $6} + | nconversationresponse '(' String ')' '(' Response ')' {ConversationResponse $3 $6} | nconversationcloseall {ConversationCloseAll} -PEnvEntry : penventry '(' String ')' '(' Values ')' {($3, $6)} +PEnvEntry : penventry '(' String ')' '(' Value ')' {($3, $6)} PEnv : penv '[' PEnvElements ']' { $3 } @@ -328,8 +336,8 @@ SStringExpElement : '(' '(' String ')' '(' Exp ')' ')' {($3, $6)} SValuesArray : svaluesarray '[' SValuesElements ']' {$3} -SValuesElements : Values ',' SValuesElements {$1 : $3} - | Values {[$1]} +SValuesElements : Value ',' SValuesElements {$1 : $3} + | Value {[$1]} | {- empty -} {[]} LabelType : slabeltype '{' SStringElements '}' {$3} diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index eb9341f..fbda109 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -129,15 +129,17 @@ tokens :- "NIntroduceClient" { tok $ const NIntroduceClient } "NNewValue" { tok $ const NNewValue } - "NSyncIncoming" { tok $ const NSyncIncoming } - "NRequestSync" { tok $ const NRequestSync } - "NChangePartnerAddress" { tok $ const NChangePartnerAddress } - "NIntroduceNewPartnerAddress" { tok $ const NIntroduceNewPartnerAddress} + "NRequestValue" { tok $ const NRequestValue } + "NAcknowledgeValue" { tok $ const NAcknowledgeValue } + "NNewPartnerAddress" { tok $ const NNewPartnerAddress } + "NAcknowledgePartnerAddress" { tok $ const NAcknowledgePartnerAddress } + "NDisconnect" { tok $ const NDisconnect } + "NAcknowledgeDisconnect" { tok $ const NAcknowledgeDisconnect } "NRedirect" { tok $ const NRedirect } "NOkay" { tok $ const NOkay } "NOkayIntroduce" { tok $ const NOkayIntroduce } - "NOkaySync" { tok $ const NOkaySync } - "NWait" { tok $ const NWait} + "NWait" { tok $ const NWait } + "NError" { tok $ const NError } "NConversationMessage" { tok $ const NConversationMessage } "NConversationResponse" { tok $ const NConversationResponse } "NConversationCloseAll" { tok $ const NConversationCloseAll } @@ -256,15 +258,17 @@ data Token | NIntroduceClient | NNewValue - | NSyncIncoming - | NRequestSync - | NChangePartnerAddress - | NIntroduceNewPartnerAddress + | NRequestValue + | NAcknowledgeValue + | NNewPartnerAddress + | NAcknowledgePartnerAddress + | NDisconnect + | NAcknowledgeDisconnect | NRedirect | NOkay | NOkayIntroduce - | NOkaySync - | NWait + | Nwait + | NError | NConversationMessage | NConversationResponse | NConversationCloseAll From d251498fdf4de3a2e33f7041b2a4be19e9d017c6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 13 Feb 2023 15:42:00 +0100 Subject: [PATCH 130/229] this probably wont work yet but the structure should be there --- src/Interpreter.hs | 5 +- src/Networking/Common.hs | 2 - src/Networking/DirectionalConnection.hs | 23 +++---- src/Networking/Server.hs | 83 ++++++++++++++++--------- 4 files changed, 65 insertions(+), 48 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index c7f099c..a32352a 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -202,7 +202,10 @@ eval = \case let dcRead = NCon.ncRead ci valunclean <- liftIO $ DC.readUnreadMessageInterpreter dcRead (env, (sockets, vchanconnections, activeConnections)) <- ask - val <- liftIO $ NS.replaceVChanSerial activeConnections vchanconnections valunclean + -- val <- liftIO $ NS.replaceVChanSerial activeConnections vchanconnections valunclean + socketsraw <- liftIO $ MVar.readMVar sockets + let port = show $ head $ Map.keys socketsraw + val <- liftIO $ NS.recieveValue vchanconnections activeConnections ci liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e -- Disable the old channel and get a new one diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index a475269..7ccbcbd 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -37,5 +37,3 @@ endConversation con waitTime tries = NetMethod.endConversation con waitTime trie sayGoodbye con = NetMethod.sayGoodbye con getPartnerHostaddress conv = NetMethod.getPartnerHostaddress conv - - diff --git a/src/Networking/DirectionalConnection.hs b/src/Networking/DirectionalConnection.hs index cb3953a..cfbadca 100644 --- a/src/Networking/DirectionalConnection.hs +++ b/src/Networking/DirectionalConnection.hs @@ -73,14 +73,14 @@ readUnreadMessageMaybe connection = modifyMVar (messagesUnreadStart connection) if length messagesBind == i then return (i, Nothing) else return ((i+1), Just (messagesBind!!i)) ) -readUnreadMessage :: DirectionalConnection a -> IO a +{-readUnreadMessage :: DirectionalConnection a -> IO a readUnreadMessage connection = do maybeval <- readUnreadMessageMaybe connection case maybeval of Nothing -> do threadDelay 5000 readUnreadMessage connection - Just val -> return val + Just val -> return val-} readMessageMaybe :: DirectionalConnection a -> Int -> IO (Maybe a) readMessageMaybe connection index = do @@ -94,20 +94,8 @@ setUnreadCount connection index = do unreadLength <- takeMVar $ messagesUnreadStart connection if index > unreadLength then putMVar (messagesUnreadStart connection) index else putMVar (messagesUnreadStart connection) unreadLength -readUnreadMessageInterpreter :: DirectionalConnection a -> IO a -readUnreadMessageInterpreter connection = do - -- debugExists <- System.Directory.doesFileExist "print.me" - -- when debugExists $ putStrLn "DC: Trying to read message" - maybeval <- SSem.withSem (readLock connection) $ readUnreadMessageMaybe connection - -- when debugExists $ putStrLn "DC: Read message" - -- allVals <- countMessages connection - -- currentRead <- readMVar $ messagesUnreadStart connection - -- when debugExists $ putStrLn $ "DC: "++ show currentRead++" out of "++show allVals - case maybeval of - Nothing -> do - threadDelay 5000 - readUnreadMessageInterpreter connection - Just val -> return val +readUnreadMessageInterpreter :: DirectionalConnection a -> IO (Maybe a) +readUnreadMessageInterpreter connection = SSem.withSem (readLock connection) $ readUnreadMessageMaybe connection serializeConnection :: DirectionalConnection a -> IO ([a], Int) serializeConnection connection = do @@ -118,6 +106,9 @@ serializeConnection connection = do countMessages :: DirectionalConnection a -> IO Int countMessages connection = readMVar $ messagesCount connection +unreadMessageStart :: DirectionalConnection a -> IO Int +unreadMessageStart connection = readMVar $ messagesUnreadStart connection + lockInterpreterReads :: DirectionalConnection a -> IO () lockInterpreterReads connection = SSem.wait (readLock connection) diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index c4ef2bf..a521c72 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -38,6 +38,14 @@ import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC import qualified Control.Concurrent.SSem as SSem import qualified Networking.DirectionalConnection as DC import qualified Networking.NetworkConnection as NCon +import qualified Networking.DirectionalConnection as DC +import Networking.NetworkingMethod.Stateless (recieveMessageInternal) +import qualified Networking.Client as NClient +import qualified Networking.DirectionalConnection as NCon +import Networking.NetworkConnection (NetworkConnection(ncRead)) +import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC +import Control.Concurrent (threadDelay) +import qualified Networking.Client as NClient checkAndSendRedirectRequest :: NC.ConversationOrHandle -> Map.Map String (NetworkConnection Value) -> String -> IO Bool checkAndSendRedirectRequest handle ncmap userid = do @@ -190,50 +198,46 @@ setPartnerHostAddress address input = case input of (fst x, newval):setPartnerHostAddressPEnv clientHostaddress xs -contactNewPeers :: NMC.ActiveConnections -> Value -> String -> IO () +waitUntilContactedNewPeers :: NMC.ActiveConnections -> Value -> String -> IO () +waitUntilContactedNewPeers activeCons input ownport = do + contactedPeers <- contactNewPeers activeCons input ownport + unless contactedPeers $ do + threadDelay 50000 + waitUntilContactedNewPeers activeCons input ownport + + +contactNewPeers :: NMC.ActiveConnections -> Value -> String -> IO Bool contactNewPeers activeCons input ownport = case input of VSend v -> do - nv <- contactNewPeers activeCons v ownport - -- return $ VSend nv - return () + contactNewPeers activeCons v ownport VPair v1 v2 -> do nv1 <- contactNewPeers activeCons v1 ownport nv2 <- contactNewPeers activeCons v2 ownport - -- return $ VPair nv1 nv2 - return () + return (nv1 || nv2) VFunc penv a b -> do - newpenv <- contactNewPeersPEnv activeCons penv ownport - -- return $ VFunc newpenv a b - return () + contactNewPeersPEnv activeCons penv ownport VDynCast v g -> do - nv <- contactNewPeers activeCons v ownport - -- return $ VDynCast nv g - return () + contactNewPeers activeCons v ownport VFuncCast v a b -> do - nv <- contactNewPeers activeCons v ownport - -- return $ VFuncCast nv a b - return () + contactNewPeers activeCons v ownport VRec penv a b c d -> do - newpenv <- contactNewPeersPEnv activeCons penv ownport - -- return $ VRec newpenv a b c d - return () + contactNewPeersPEnv activeCons penv ownport VNewNatRec penv a b c d e f g -> do - newpenv <- contactNewPeersPEnv activeCons penv ownport - -- return $ VNewNatRec newpenv a b c d e f g - return () - VChanSerial r w p o c -> do - let (hostname, port) = c - tempNC <- newNetworkConnection p o hostname port - NClient.sendNetworkMessage activeCons tempNC (Messages.IntroduceNewPartnerAddress o ownport) 5 - _ -> return () -- return input + contactNewPeersPEnv activeCons penv ownport + VChan nc bool -> do + connectionState <- MVar.readMVar $ ncConnectionState nc + if csConfirmedConnection connectionState then return True else do + NClient.sendNetworkMessage activeCons tempNC (Messages.IntroduceNewPartnerAddress o ownport) 0 + return False + _ -> return True where - contactNewPeersPEnv :: NMC.ActiveConnections -> [(String, Value)] -> String -> IO () -- [(String, Value)] - contactNewPeersPEnv _ [] _ = return () --return [] + contactNewPeersPEnv :: NMC.ActiveConnections -> [(String, Value)] -> String -> IO Bool -- [(String, Value)] + contactNewPeersPEnv _ [] _ = return True contactNewPeersPEnv activeCons (x:xs) ownport = do newval <- contactNewPeers activeCons (snd x) ownport rest <- contactNewPeersPEnv activeCons xs ownport -- return $ (fst x, newval):rest - return () + return (newval || rest) hostaddressTypeToString :: HostAddress -> String hostaddressTypeToString hostaddress = do @@ -314,3 +318,24 @@ replaceVChanSerial activeCons mvar input = case input of newval <- replaceVChanSerial activeCons mvar $ snd x rest <- replaceVChanSerialPEnv activeCons mvar xs return $ (fst x, newval):rest + + +recieveValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value +recieveValue = recieveValueInternal 0 + where + recieveValueInternal count vchanconsvar activeCons networkconnection ownport = do + mbyUnclean <- DC.readUnreadMessageInterpreter + case mbyUnclean of + Just unclean -> do + val <- NS.replaceVChanSerial activeConnections vchanconnections unclean + waitUntilContactedNewPeers vchanconsvar val ownport + msgCount <- NCon.unreadMessageStart $ ncRead networkconnection + NClient.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (Data.Maybe.fromMaybe "" (ncOwnUserID networkcon)) $ msgCount-1) + return val + Nothing -> if count == 0 then do + msgCount <- NCon.countMessages $ ncRead networkconnection + NClient.sendNetworkMessage activeCons networkconnection (Messages.RequestValue (Data.Maybe.fromMaybe "" (ncOwnUserID networkcon)) msgCount) + recieveValueInternal 10 vchanconsvar activeCons networkconnection ownport + else do + threadDelay 50000 + recieveValueInternal (count-1) vchanconsvar activeCons networkconnection ownport From f7be4397e56df5a33eaed692c57576fd047318a3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 13 Feb 2023 16:49:12 +0100 Subject: [PATCH 131/229] Still not compiling, but should include all the major concepts --- src/Interpreter.hs | 1 + src/Networking/Client.hs | 26 +++++++++++++++++++- src/Networking/NetworkingMethod/Fast.hs | 1 + src/Networking/NetworkingMethod/Stateless.hs | 4 +++ src/ValueParsing/ValueGrammar.y | 2 +- 5 files changed, 32 insertions(+), 2 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index a32352a..343c3db 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -106,6 +106,7 @@ interpret decls = do vchanconnections <- MVar.newMVar Map.empty activeConnections <- NC.createActiveConnections result <- R.runReaderT (interpretDecl decls) ([], (sockets, vchanconnections, activeConnections)) + NClient.sendDisconnect activeConnections vchanconnections NC.sayGoodbye activeConnections return result diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index a505c23..3bf26a4 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -30,6 +30,7 @@ import qualified Networking.Serialize as NSerialize import Control.Monad import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC import qualified Control.Concurrent.SSem as SSem +import Networking.NetworkConnection (NetworkConnection(ncConnectionState)) newtype ClientException = NoIntroductionException String @@ -268,4 +269,27 @@ replaceVChan input = case input of replaceVChanPEnv (x:xs) = do newval <- replaceVChan $ snd x rest <- replaceVChanPEnv xs - return $ (fst x, newval):rest \ No newline at end of file + return $ (fst x, newval):rest + +sendDisconnect :: ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> IO () +sendDisconnect ac mvar = do + networkConnectionMap <- MVar.readMVar mvar + let allNetworkConnections = Map.elems networConnectionMap + goodbyes <- doForall ac allNetworkConnections + unless goodbyes $ do + threadDelay 100000 + sendDisconnect ac mvar + where + doForall ac (x:xs) = do + xres <- sendDisconnectNetworkConnection ac x + rest <- doForall ac xs + return xres && rest + sendDisconnectNetworkConnection ac con = do + writeVals <- MVar.readMVar ncWrite con + connectionState <- MVar.readMVar ncConnectionState con + unreadVals <- DC.unreadMessageStart writeVals + lengthVals <- DC.countMessages writeVals + if unreadVals == lengthVals then do + when (connectionState /= Disconnected {}) $ sentNetworkMessage ac con (Messages.Disconnect $ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) (-1) + return True + else return False \ No newline at end of file diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index f61e52c..d39f96f 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -23,6 +23,7 @@ import qualified Config import qualified Networking.NetworkingMethod.Stateless as Stateless import ProcessEnvironmentTypes import qualified Control.Concurrent.SSem as SSem +import qualified Networking.Common as Stateless type ResponseMapMVar = MVar.MVar (Map.Map String (String, Responses)) diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index aa81e6e..f7b38fb 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -14,12 +14,15 @@ import Control.Exception import Networking.Messages import Networking.NetworkConnection +import qualified Networking.DirectionalConnection as DC import ProcessEnvironmentTypes import qualified Networking.Serialize as NSerialize import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG import qualified Config import qualified Syntax +import qualified Networking.DirectionalConnection as DC +import qualified Networking.DirectionalConnection as DC type ConnectionHandler = ActiveConnectionsStateless -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> Conversation -> String -> String -> Messages -> IO () @@ -192,6 +195,7 @@ getHandleFromSocket socket = do sayGoodbye :: ActiveConnectionsStateless -> IO () sayGoodbye _ = return () + {-isClosed :: Conversation -> IO Bool isClosed = hIsClosed . fst-} diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index f7328b2..5813dac 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -117,7 +117,7 @@ import Networking.Messages nintroduceclient { T _ T.NIntroduceClient } nnewvalue { T _ T.NNewValue } - nrequestsync { T _ T.NRequestSync } + nrequestvalue { T _ T.NRequestValue } nacknowledgevalue {T _ T.NAcknowledgeValue } nnewpartneraddress {T _ T.NNewPartnerAddress } nacknowledgepartneraddress {T _ T.NAcknowledgePartnerAddress } From c16d8f3cd944c4af8d1ddbb09f98fbfb232221b2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 13 Feb 2023 17:33:11 +0100 Subject: [PATCH 132/229] fixes towards getting it compiled later --- src/Networking/Client.hs | 41 ++++++++++--------- src/Networking/DirectionalConnection.hs | 5 ++- src/Networking/NetworkingMethod/Fast.hs | 13 +++--- .../NetworkingMethodCommon.hs | 2 +- src/Networking/NetworkingMethod/Stateless.hs | 6 +-- src/Networking/Serialize.hs | 9 +++- src/ProcessEnvironmentTypes.hs | 11 ++--- src/ValueParsing/ValueGrammar.y | 6 ++- src/ValueParsing/ValueTokens.x | 2 +- 9 files changed, 53 insertions(+), 42 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 3bf26a4..f63f303 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -46,14 +46,14 @@ sendValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Valu sendValue vchanconsmvar activeCons networkconnection val ownport resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of - NCon.Connected hostname port -> do + NCon.Connected hostname port _ _ _-> do setRedirectRequests vchanconsmvar hostname port ownport val valcleaned <- replaceVChan val DC.writeMessage (ncWrite networkconnection) valcleaned messagesCount <- DC.countMessages $ ncWrite networkconnection tryToSendNetworkMessage activeCons networkconnection hostname port (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) messagesCount valcleaned) resendOnError - disableVChans val - NCon.Emulated -> do + -- disableVChans val + NCon.Emulated {} -> do vchancons <- MVar.readMVar vchanconsmvar valCleaned <- replaceVChan val DC.writeMessage (ncWrite networkconnection) valCleaned @@ -62,18 +62,18 @@ sendValue vchanconsmvar activeCons networkconnection val ownport resendOnError = case mbypartner of Just partner -> DC.writeMessage (ncRead partner) valCleaned _ -> Config.traceNetIO "Something went wrong when sending over a emulated connection" - disableVChans val + -- disableVChans val _ -> Config.traceNetIO "Error when sending message: This channel is disconnected" -sendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> Messages -> Int -> IO () +sendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> Message -> Int -> IO () sendNetworkMessage activeCons networkconnection message resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of - NCon.Connected hostname port -> do + NCon.Connected {} -> do tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError _ -> Config.traceNetIO "Error when sending message: This channel is disconnected" -tryToSendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> String -> String -> Messages -> Int -> IO () +tryToSendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> String -> String -> Message -> Int -> IO () tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError = do serializedMessage <- NSerialize.serialize message sendingNetLog serializedMessage $ "Sending message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection) ++ " to: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkconnection) ++ " Over: " ++ hostname ++ ":" ++ port @@ -165,7 +165,7 @@ initialConnect activeCons mvar hostname port ownport syntype= do Config.traceNetIO $ "Sending message as: " ++ ownuserid ++ " to: " ++ introductionanswer Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port Config.traceNetIO $ " Message: " ++ msgserial - newConnection <- newNetworkConnection introductionanswer ownuserid hostname port + newConnection <- newNetworkConnection introductionanswer ownuserid hostname port introductionanswer ownuserid networkconnectionmap <- MVar.takeMVar mvar let newNetworkconnectionmap = Map.insert introductionanswer newConnection networkconnectionmap MVar.putMVar mvar newNetworkconnectionmap @@ -187,7 +187,7 @@ initialConnect activeCons mvar hostname port ownport syntype= do threadDelay 1000000 initialConnect activeCons mvar hostname port ownport syntype - +-- This is still broken setRedirectRequests :: VChanConnections -> String -> String -> String -> Value -> IO () setRedirectRequests vchanconmvar newhost newport ownport input = case input of VSend v -> setRedirectRequests vchanconmvar newhost newport ownport v @@ -205,9 +205,9 @@ setRedirectRequests vchanconmvar newhost newport ownport input = case input of SSem.withSem (ncHandlingIncomingMessage nc) (do oldconnectionstate <- MVar.takeMVar $ ncConnectionState nc case oldconnectionstate of - Connected hostname port -> MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest hostname port newhost newport - RedirectRequest hostname port _ _ -> MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest hostname port newhost newport - Emulated -> do + Connected hostname port partConID ownConID confirmed -> MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest hostname port newhost newport partConID ownConID confirmed + RedirectRequest hostname port _ _ partConID ownConID confirmed -> MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest hostname port newhost newport partConID ownConID confirmed + Emulated partConID ownConID confirmed -> do Config.traceNetIO "TODO: Allow RedirectRequest for Emulated channel" vchanconnections <- MVar.takeMVar vchanconmvar @@ -215,16 +215,16 @@ setRedirectRequests vchanconmvar newhost newport ownport input = case input of let mbypartner = Map.lookup (Data.Maybe.fromMaybe "" userid) vchanconnections case mbypartner of Just partner -> do - MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest "" ownport newhost newport -- Setting this to 127.0.0.1 is a temporary hack + MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest "" ownport newhost newport partConID ownConID confirmed -- Setting this to 127.0.0.1 is a temporary hack oldconectionstatePartner <- MVar.takeMVar $ ncConnectionState partner - MVar.putMVar (ncConnectionState partner) $ NCon.Connected newhost newport + MVar.putMVar (ncConnectionState partner) $ NCon.Connected newhost newport partConID ownConID confirmed Nothing -> do MVar.putMVar (ncConnectionState nc) oldconnectionstate Config.traceNetIO "Error occured why getting the linked emulated channel" MVar.putMVar vchanconmvar vchanconnections - Disconnected -> Config.traceNetIO "Cannot set RedirectRequest for a disconnected channel" + Disconnected partConID ownConID confirmed -> Config.traceNetIO "Cannot set RedirectRequest for a disconnected channel" ) Config.traceNetIO $ "Set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport _ -> return () @@ -260,8 +260,8 @@ replaceVChan input = case input of newpenv <- replaceVChanPEnv penv return $ VNewNatRec newpenv a b c d e f g VChan nc _-> do - (r, rl, w, wl, pid, oid, h, p) <- serializeNetworkConnection nc - return $ VChanSerial (r, rl) (w, wl) pid oid (h, p) + (r, rl, w, wl, pid, oid, h, p, partConID) <- serializeNetworkConnection nc + return $ VChanSerial (r, rl) (w, wl) pid oid (h, p, partConID) _ -> return input where replaceVChanPEnv :: [(String, Value)] -> IO [(String, Value)] @@ -271,10 +271,10 @@ replaceVChan input = case input of rest <- replaceVChanPEnv xs return $ (fst x, newval):rest -sendDisconnect :: ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> IO () +sendDisconnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> IO () sendDisconnect ac mvar = do networkConnectionMap <- MVar.readMVar mvar - let allNetworkConnections = Map.elems networConnectionMap + let allNetworkConnections = Map.elems networkConnectionMap goodbyes <- doForall ac allNetworkConnections unless goodbyes $ do threadDelay 100000 @@ -283,7 +283,8 @@ sendDisconnect ac mvar = do doForall ac (x:xs) = do xres <- sendDisconnectNetworkConnection ac x rest <- doForall ac xs - return xres && rest + return $ xres && rest + doForall ac [] = return True sendDisconnectNetworkConnection ac con = do writeVals <- MVar.readMVar ncWrite con connectionState <- MVar.readMVar ncConnectionState con diff --git a/src/Networking/DirectionalConnection.hs b/src/Networking/DirectionalConnection.hs index cfbadca..854524f 100644 --- a/src/Networking/DirectionalConnection.hs +++ b/src/Networking/DirectionalConnection.hs @@ -73,14 +73,15 @@ readUnreadMessageMaybe connection = modifyMVar (messagesUnreadStart connection) if length messagesBind == i then return (i, Nothing) else return ((i+1), Just (messagesBind!!i)) ) -{-readUnreadMessage :: DirectionalConnection a -> IO a +-- Basically only used for the internal tests at this point +readUnreadMessage :: DirectionalConnection a -> IO a readUnreadMessage connection = do maybeval <- readUnreadMessageMaybe connection case maybeval of Nothing -> do threadDelay 5000 readUnreadMessage connection - Just val -> return val-} + Just val -> return val readMessageMaybe :: DirectionalConnection a -> Int -> IO (Maybe a) readMessageMaybe connection index = do diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index d39f96f..60048ae 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -23,13 +23,12 @@ import qualified Config import qualified Networking.NetworkingMethod.Stateless as Stateless import ProcessEnvironmentTypes import qualified Control.Concurrent.SSem as SSem -import qualified Networking.Common as Stateless -type ResponseMapMVar = MVar.MVar (Map.Map String (String, Responses)) +type ResponseMapMVar = MVar.MVar (Map.Map String (String, Response)) data Conversation = Conversation {convID :: String, convHandle :: Stateless.Conversation, convRespMap :: ResponseMapMVar, convSending :: SSem.SSem} -type ConnectionHandler = ActiveConnectionsFast -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> Conversation -> String -> String -> Messages -> IO () +type ConnectionHandler = ActiveConnectionsFast -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> Conversation -> String -> String -> Message -> IO () -- type NetworkAddress = (String, String) -- deriving (Eq, Show, Ord) @@ -37,10 +36,10 @@ type ConnectionHandler = ActiveConnectionsFast -> MVar.MVar (Map.Map String (Net -- type Connectionhandler = MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Messages -> IO () -sendMessage :: Conversation -> Messages -> IO () +sendMessage :: Conversation -> Message -> IO () sendMessage conv value = SSem.withSem (convSending conv) $ Stateless.sendMessage (convHandle conv) (ConversationMessage (convID conv) value) -sendResponse :: Conversation -> Responses -> IO () +sendResponse :: Conversation -> Response -> IO () sendResponse conv value = SSem.withSem (convSending conv) $ Stateless.sendResponse (convHandle conv) (ConversationResponse (convID conv) value) conversationHandler :: Stateless.Conversation -> IO Connection @@ -90,7 +89,7 @@ conversationHandlerChangeHandle handle chan mvar sem = do -recieveResponse :: Conversation -> Int -> Int -> IO (Maybe Responses) +recieveResponse :: Conversation -> Int -> Int -> IO (Maybe Response) recieveResponse conv waitTime tries = do -- Config.traceNetIO "Trying to take mvar for responses mvar" responsesMap <- MVar.readMVar $ convRespMap conv @@ -107,7 +106,7 @@ recieveResponse conv waitTime tries = do threadDelay waitTime recieveResponse conv waitTime $ max (tries-1) (-1) else return Nothing -recieveNewMessage :: Connection -> IO (Conversation, String, Messages) +recieveNewMessage :: Connection -> IO (Conversation, String, Message) recieveNewMessage connection@(handle, isClosed, chan, mvar, sem) = do (cid, (serial, deserial)) <- Chan.readChan chan return (Conversation cid handle mvar sem, serial, deserial) diff --git a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs index 1ba20be..72b1217 100644 --- a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs +++ b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs @@ -16,7 +16,7 @@ data ActiveConnectionsStateless = ActiveConnectionsStateless type ConversationStateless = (Handle, (Socket, SockAddr)) -type Connection = (ConversationStateless, MVar.MVar Bool, Chan.Chan (String, (String, Messages)), MVar.MVar (Map.Map String (String, Responses)), SSem.SSem) +type Connection = (ConversationStateless, MVar.MVar Bool, Chan.Chan (String, (String, Message)), MVar.MVar (Map.Map String (String, Response)), SSem.SSem) -- isClosed Conversationid serial deserial type ActiveConnectionsFast = MVar.MVar (Map.Map NetworkAddress Connection) diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index f7b38fb..bc60f9c 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -24,7 +24,7 @@ import qualified Syntax import qualified Networking.DirectionalConnection as DC import qualified Networking.DirectionalConnection as DC -type ConnectionHandler = ActiveConnectionsStateless -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> Conversation -> String -> String -> Messages -> IO () +type ConnectionHandler = ActiveConnectionsStateless -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> Conversation -> String -> String -> Message -> IO () type Conversation = ConversationStateless @@ -162,13 +162,13 @@ getFromNetworkThreadWithModification conv func threadid mvar waitTime currentTry killThread threadid return Nothing -recieveResponse :: Conversation -> Int -> Int -> IO (Maybe Responses) +recieveResponse :: Conversation -> Int -> Int -> IO (Maybe Response) recieveResponse conv waitTime tries = do retVal <- MVar.newEmptyMVar threadid <- forkIO $ recieveMessageInternal conv VG.parseResponses (\_ -> MVar.putMVar retVal Nothing) (\_ des -> MVar.putMVar retVal $ Just des) getFromNetworkThreadWithModification (Just conv) id threadid retVal waitTime tries -recieveNewMessage :: Conversation -> IO (Conversation, String, Messages) +recieveNewMessage :: Conversation -> IO (Conversation, String, Message) recieveNewMessage conv = do recieveMessageInternal conv VG.parseMessages (\_ -> recieveNewMessage conv) $ \s des -> return (conv, s, des) diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index 6ecdc73..e84fa65 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -71,7 +71,7 @@ instance Serializable (NCon.DirectionalConnection Value) where instance Serializable NCon.ConnectionState where serialize = \case - NCon.Connected hostname port-> serializeLabeledEntryMulti "SConnected" hostname $ sLast port + NCon.Connected hostname port partnerConnectionID _ _ -> serializeLabeledEntryMulti "SConnected" hostname $ sNext port $ sLast partnerConnectionID _ -> throw $ UnserializableException "VChan can only be serialized when in Connected mode" instance Serializable Value where @@ -228,6 +228,13 @@ instance ((Serializable a, Serializable b) => Serializable (a, b)) where ts <- serialize t return $ "((" ++ ss ++ ") (" ++ ts ++ "))" +instance ((Serializable a, Serializable b, Serializable c) => Serializable (a, b, c)) where + serialize (s, t, v) = do + ss <- serialize s + ts <- serialize t + vs <- serialize v + return $ "((" ++ ss ++ ") (" ++ ts ++ ") (" ++ ts ++ "))" + instance {-# OVERLAPPING #-} Serializable PEnv where serialize arr = serializeLabeledArray "PEnv" arr diff --git a/src/ProcessEnvironmentTypes.hs b/src/ProcessEnvironmentTypes.hs index 0454e3d..c88a9ae 100644 --- a/src/ProcessEnvironmentTypes.hs +++ b/src/ProcessEnvironmentTypes.hs @@ -54,7 +54,7 @@ data Value | VDouble Double | VString String | VChan (NCon.NetworkConnection Value) (MVar.MVar Bool) --Maybe a "used" mvar to notify that this vchan should no longer be used - | VChanSerial ([Value], Int) ([Value], Int) String String (String, String) + | VChanSerial ([Value], Int) ([Value], Int) String String (String, String, String) | VSend Value | VPair Value Value -- pair of ids that map to two values | VType S.Type @@ -78,15 +78,16 @@ disableOldVChan value = case value of _ -> return value +{- disableVChan :: Value -> IO () disableVChan value = case value of VChan nc _ -> do mbystate <- MVar.tryTakeMVar $ NCon.ncConnectionState nc --I dont fully understand why this mvar isnt filled but lets bypass this problem case mbystate of - Nothing -> MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected + Nothing -> MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected Just state -> case state of - NCon.Connected _ _ -> MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected - NCon.Emulated -> MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected + NCon.Connected {} -> MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected + NCon.Emulated {} -> MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected _ -> MVar.putMVar (NCon.ncConnectionState nc) state _ -> return () @@ -132,7 +133,7 @@ disableVChans input = case input of rest <- disableVChansPEnv xs return () -- return $ (fst x, newval):rest - +-} instance Show Value where show = \case diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 5813dac..f0d48bc 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -192,7 +192,7 @@ Value : vunit { VUnit } | vstring '(' String ')' {VString $3 } -- | vchan '(' SValuesArray ')' '(' int ')' '(' SValuesArray ')' '(' int ')' '(' String ')' '(' String ')' '(' String ')' '(' String ')' {VChanSerial $3 $6 $9 $12 $15 $18 $21 $24 } | vchan '(' NetworkConnection ')' {$3} - | vchanserial '(' SArrayIntElement ')' '(' SArrayIntElement ')' '(' String ')' '(' String ')' '(' SStringStringElement ')' {VChanSerial $3 $6 $9 $12 $15} + | vchanserial '(' SArrayIntElement ')' '(' SArrayIntElement ')' '(' String ')' '(' String ')' '(' SStringStringElement3 ')' {VChanSerial $3 $6 $9 $12 $15} | vsend '(' Value ')' {VSend $3} | vpair '(' Value ')' '(' Value ')' {VPair $3 $6} | vtype '(' Type ')' {VType $3} @@ -208,7 +208,7 @@ NetworkConnection : snetworkconnection '(' DirectionalConnection ')' '(' Directi DirectionalConnection : sdirectionalconnection '(' SValuesArray ')' '(' int ')' {($3, $6)} -ConnectionState : sconnected '(' String ')' '(' String ')' {($3, $6)} +ConnectionState : sconnected '(' String ')' '(' String ')' '(' String ')' {($3, $6, $9)} Mult : mone { MOne } @@ -346,6 +346,8 @@ SArrayIntElement : '(' '(' SValuesArray ')' '(' int ')' ')' {($3, $6)} SStringStringElement : '(' '(' String ')' '(' String ')' ')' {($3, $6)} +SStringStringElement3 : '(' '(' String ')' '(' String ')' '(' String ')' ')' {($3, $6, $9)} + { diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index fbda109..ef2b296 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -267,7 +267,7 @@ data Token | NRedirect | NOkay | NOkayIntroduce - | Nwait + | NWait | NError | NConversationMessage | NConversationResponse From f874fcf3f6a7812b282d61cd87158a269e1f035b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 13 Feb 2023 18:08:17 +0100 Subject: [PATCH 133/229] Code builds again --- src/Interpreter.hs | 2 +- src/Networking/Client.hs | 16 +++++++++------- src/Networking/Server.hs | 37 +++++++++++++++++++------------------ 3 files changed, 29 insertions(+), 26 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 343c3db..702f9b7 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -206,7 +206,7 @@ eval = \case -- val <- liftIO $ NS.replaceVChanSerial activeConnections vchanconnections valunclean socketsraw <- liftIO $ MVar.readMVar sockets let port = show $ head $ Map.keys socketsraw - val <- liftIO $ NS.recieveValue vchanconnections activeConnections ci + val <- liftIO $ NS.recieveValue vchanconnections activeConnections ci port liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e -- Disable the old channel and get a new one diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index f63f303..0abb9ea 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -46,7 +46,7 @@ sendValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Valu sendValue vchanconsmvar activeCons networkconnection val ownport resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of - NCon.Connected hostname port _ _ _-> do + NCon.Connected hostname port _ _ _ -> do setRedirectRequests vchanconsmvar hostname port ownport val valcleaned <- replaceVChan val DC.writeMessage (ncWrite networkconnection) valcleaned @@ -69,7 +69,7 @@ sendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> Messag sendNetworkMessage activeCons networkconnection message resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of - NCon.Connected {} -> do + NCon.Connected hostname port _ _ _ -> do tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError _ -> Config.traceNetIO "Error when sending message: This channel is disconnected" @@ -98,7 +98,7 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen Okay -> sendingNetLog serializedMessage "Message okay" Redirect host port -> do sendingNetLog serializedMessage "Communication partner changed address, resending" - NCon.changePartnerAddress networkconnection host port + -- NCon.changePartnerAddress networkconnection host port "" -- TODO properly fix this tryToSendNetworkMessage activeCons networkconnection host port message resendOnError Wait -> do sendingNetLog serializedMessage "Communication out of sync lets wait!" @@ -114,6 +114,7 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen sendingNetLog :: String -> String -> IO () sendingNetLog msg info = Config.traceNetIO $ "Sending message: "++msg++" \n Status: "++info +{- setPartnerHostAddress :: String -> Value -> Value setPartnerHostAddress address input = case input of VSend v -> VSend $ setPartnerHostAddress address v @@ -142,7 +143,7 @@ setPartnerHostAddress address input = case input of setPartnerHostAddressPEnv clientHostaddress penvs@(x:xs) = let newval = setPartnerHostAddress clientHostaddress $ snd x in (fst x, newval):setPartnerHostAddressPEnv clientHostaddress xs - +-} printConErr :: String -> String -> IOException -> IO () printConErr hostname port err = Config.traceIO $ "Communication Partner " ++ hostname ++ ":" ++ port ++ "not found!" @@ -285,12 +286,13 @@ sendDisconnect ac mvar = do rest <- doForall ac xs return $ xres && rest doForall ac [] = return True + sendDisconnectNetworkConnection :: NMC.ActiveConnections -> NetworkConnection Value -> IO Bool sendDisconnectNetworkConnection ac con = do - writeVals <- MVar.readMVar ncWrite con - connectionState <- MVar.readMVar ncConnectionState con + let writeVals = ncWrite con + connectionState <- MVar.readMVar $ ncConnectionState con unreadVals <- DC.unreadMessageStart writeVals lengthVals <- DC.countMessages writeVals if unreadVals == lengthVals then do - when (connectionState /= Disconnected {}) $ sentNetworkMessage ac con (Messages.Disconnect $ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) (-1) + when (connectionState /= Disconnected {}) $ sendNetworkMessage ac con (Messages.Disconnect $ Data.Maybe.fromMaybe "" (ncOwnUserID con)) (-1) return True else return False \ No newline at end of file diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index a521c72..4ca33c7 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -53,7 +53,7 @@ checkAndSendRedirectRequest handle ncmap userid = do Nothing -> return False -handleClient :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> Messages -> IO () +handleClient :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> Message -> IO () handleClient activeCons mvar clientlist clientsocket hdl ownport message deserialmessages = do let userid = getUserID deserialmessages clientHostaddress <- case snd clientsocket of @@ -72,7 +72,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria Just num -> do constate <- MVar.readMVar $ ncConnectionState networkcon reply <- case constate of - RedirectRequest _ _ host port -> do + RedirectRequest _ _ host port _ _ _ -> do recievedNetLog message $ "Found redirect request for: " ++ userid recievedNetLog message $ "Send redirect to:" ++ host ++ ":" ++ port SSem.signal $ ncHandlingIncomingMessage networkcon @@ -88,16 +88,17 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria recievedNetLog message "Sent okay" ND.unlockInterpreterReads (ncRead networkcon) return Nothing - Requestvalue userid count -> do + RequestValue userid count -> do SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Okay - mbyval <- DC.readMessageMaybe $ NCon.ncWrite networkcon - Data.Maybe.maybe (return ()) (\val -> sendNetworkMessage activeCons networkcon (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkcon) count val) 0) mbyval + mbyval <- DC.readMessageMaybe (NCon.ncWrite networkcon) count + Data.Maybe.maybe (return ()) (\val -> NClient.sendNetworkMessage activeCons networkcon (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkcon) count val) 0) mbyval return Nothing AcknowledgeValue userid count -> do DC.setUnreadCount (NCon.ncWrite networkcon) count SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Okay + return Nothing NewPartnerAddress userid port connectionID -> do recievedNetLog message $ "Trying to change the address to: " ++ clientHostaddress ++ ":" ++ port NCon.changePartnerAddress networkcon clientHostaddress port connectionID @@ -109,7 +110,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria SSem.signal $ ncHandlingIncomingMessage networkcon if conConfirmed then NC.sendResponse hdl Messages.Okay else NC.sendResponse hdl Messages.Error return Nothing - Disconnect UserID -> do + Disconnect userid -> do NCon.disconnectFromPartner networkcon SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Okay @@ -137,7 +138,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria case deserialmessages of IntroduceClient userid clientport synname syntype -> do serverid <- UserID.newRandomUserID - newpeer <- newNetworkConnection userid serverid clientHostaddress clientport + newpeer <- newNetworkConnection userid serverid clientHostaddress clientport userid serverid NC.sendResponse hdl (Messages.OkayIntroduce serverid) repserial <- NSerialize.serialize $ Messages.OkayIntroduce serverid recievedNetLog message $ " Response to "++ userid ++ ": " ++ repserial @@ -146,9 +147,6 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria MVar.putMVar clientlist $ clientlistraw ++ [(userid, (synname, syntype))] return $ Just newpeer - IntroduceNewPartnerAddress userid port -> do - placeholder <- NCon.newPlaceHolderConnection userid clientHostaddress port - return $ Just placeholder _ -> do serial <- NSerialize.serialize deserialmessages recievedNetLog message $ "Error unsupported networkmessage: "++ serial @@ -168,6 +166,7 @@ recievedNetLog :: String -> String -> IO () recievedNetLog msg info = Config.traceNetIO $ "Recieved message: "++msg++" \n Status: "++info +{- setPartnerHostAddress :: String -> Value -> Value setPartnerHostAddress address input = case input of VSend v -> VSend $ setPartnerHostAddress address v @@ -196,7 +195,7 @@ setPartnerHostAddress address input = case input of setPartnerHostAddressPEnv clientHostaddress penvs@(x:xs) = let newval = setPartnerHostAddress clientHostaddress $ snd x in (fst x, newval):setPartnerHostAddressPEnv clientHostaddress xs - +-} waitUntilContactedNewPeers :: NMC.ActiveConnections -> Value -> String -> IO () waitUntilContactedNewPeers activeCons input ownport = do @@ -227,7 +226,7 @@ contactNewPeers activeCons input ownport = case input of VChan nc bool -> do connectionState <- MVar.readMVar $ ncConnectionState nc if csConfirmedConnection connectionState then return True else do - NClient.sendNetworkMessage activeCons tempNC (Messages.IntroduceNewPartnerAddress o ownport) 0 + NClient.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) 0 return False _ -> return True where @@ -306,7 +305,7 @@ replaceVChanSerial activeCons mvar input = case input of Nothing -> return () MVar.putMVar mvar $ Map.insert p networkconnection ncmap - NClient.sendNetworkMessage activeCons networkconnection (RequestSync o $ length r) 5 + -- NClient.sendNetworkMessage activeCons networkconnection (RequestSync o $ length r) 5 used<- MVar.newEmptyMVar MVar.putMVar used False return $ VChan networkconnection used @@ -323,18 +322,20 @@ replaceVChanSerial activeCons mvar input = case input of recieveValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value recieveValue = recieveValueInternal 0 where + recieveValueInternal :: Int -> VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value recieveValueInternal count vchanconsvar activeCons networkconnection ownport = do - mbyUnclean <- DC.readUnreadMessageInterpreter + let readDC = ncRead networkconnection + mbyUnclean <- DC.readUnreadMessageInterpreter readDC case mbyUnclean of Just unclean -> do - val <- NS.replaceVChanSerial activeConnections vchanconnections unclean - waitUntilContactedNewPeers vchanconsvar val ownport + val <- replaceVChanSerial activeCons vchanconsvar unclean + waitUntilContactedNewPeers activeCons val ownport msgCount <- NCon.unreadMessageStart $ ncRead networkconnection - NClient.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (Data.Maybe.fromMaybe "" (ncOwnUserID networkcon)) $ msgCount-1) + NClient.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) $ msgCount-1) 0 return val Nothing -> if count == 0 then do msgCount <- NCon.countMessages $ ncRead networkconnection - NClient.sendNetworkMessage activeCons networkconnection (Messages.RequestValue (Data.Maybe.fromMaybe "" (ncOwnUserID networkcon)) msgCount) + NClient.sendNetworkMessage activeCons networkconnection (Messages.RequestValue (Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) msgCount) 0 recieveValueInternal 10 vchanconsvar activeCons networkconnection ownport else do threadDelay 50000 From 99f163a1d5359a9d9b1f49d9a5422d9887d00718 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 13 Feb 2023 18:53:54 +0100 Subject: [PATCH 134/229] Fixed another bug readUnreadMessageInterpreter was executed twice, even though it only should have been called once --- src/Interpreter.hs | 2 +- src/Networking/DirectionalConnection.hs | 2 +- src/Networking/Server.hs | 1 + 3 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 702f9b7..42da50e 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -201,7 +201,7 @@ eval = \case used <- liftIO $ MVar.readMVar usedmvar if used then throw $ VChanIsUsedException $ show v else do let dcRead = NCon.ncRead ci - valunclean <- liftIO $ DC.readUnreadMessageInterpreter dcRead + -- valunclean <- liftIO $ DC.readUnreadMessageInterpreter dcRead (env, (sockets, vchanconnections, activeConnections)) <- ask -- val <- liftIO $ NS.replaceVChanSerial activeConnections vchanconnections valunclean socketsraw <- liftIO $ MVar.readMVar sockets diff --git a/src/Networking/DirectionalConnection.hs b/src/Networking/DirectionalConnection.hs index 854524f..e92cab2 100644 --- a/src/Networking/DirectionalConnection.hs +++ b/src/Networking/DirectionalConnection.hs @@ -70,7 +70,7 @@ allMessages connection = readMVar (messages connection) readUnreadMessageMaybe :: DirectionalConnection a -> IO (Maybe a) readUnreadMessageMaybe connection = modifyMVar (messagesUnreadStart connection) (\i -> do messagesBind <- allMessages connection - if length messagesBind == i then return (i, Nothing) else return ((i+1), Just (messagesBind!!i)) + if length messagesBind <= i then return (i, Nothing) else return ((i+1), Just (messagesBind!!i)) ) -- Basically only used for the internal tests at this point diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 4ca33c7..439a257 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -326,6 +326,7 @@ recieveValue = recieveValueInternal 0 recieveValueInternal count vchanconsvar activeCons networkconnection ownport = do let readDC = ncRead networkconnection mbyUnclean <- DC.readUnreadMessageInterpreter readDC + Config.traceNetIO $ "Current unreadMSG:" ++ show mbyUnclean case mbyUnclean of Just unclean -> do val <- replaceVChanSerial activeCons vchanconsvar unclean From 9121732d1f8ad5378db8a072f1166edef3a91472 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 13 Feb 2023 19:42:40 +0100 Subject: [PATCH 135/229] Simple conversations now work --- src/Interpreter.hs | 3 +++ src/Networking/Client.hs | 5 ++++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 42da50e..494412d 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -106,8 +106,11 @@ interpret decls = do vchanconnections <- MVar.newMVar Map.empty activeConnections <- NC.createActiveConnections result <- R.runReaderT (interpretDecl decls) ([], (sockets, vchanconnections, activeConnections)) + C.traceNetIO "Finished interpreting" NClient.sendDisconnect activeConnections vchanconnections + C.traceNetIO "Sent client disconnects" NC.sayGoodbye activeConnections + C.traceNetIO "Done" return result interpretDecl :: [Decl] -> InterpretM Value diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 0abb9ea..dcdaada 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -274,6 +274,7 @@ replaceVChan input = case input of sendDisconnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> IO () sendDisconnect ac mvar = do + Config.traceNetIO "Trying to disconnect all peers" networkConnectionMap <- MVar.readMVar mvar let allNetworkConnections = Map.elems networkConnectionMap goodbyes <- doForall ac allNetworkConnections @@ -292,7 +293,9 @@ sendDisconnect ac mvar = do connectionState <- MVar.readMVar $ ncConnectionState con unreadVals <- DC.unreadMessageStart writeVals lengthVals <- DC.countMessages writeVals - if unreadVals == lengthVals then do + Config.traceNetIO $ show unreadVals ++ "/" ++ show lengthVals + if unreadVals >= lengthVals-1 then do + Config.traceNetIO "Found a member to disconnect" when (connectionState /= Disconnected {}) $ sendNetworkMessage ac con (Messages.Disconnect $ Data.Maybe.fromMaybe "" (ncOwnUserID con)) (-1) return True else return False \ No newline at end of file From 7fab3ea92e8cb28c5ea0b47bab978325b72be53e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 13 Feb 2023 19:54:38 +0100 Subject: [PATCH 136/229] Fixed minor logic bug --- src/Networking/Client.hs | 7 +++++-- src/Networking/DirectionalConnection.hs | 2 +- src/Networking/Server.hs | 2 +- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index dcdaada..a4b6648 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -294,8 +294,11 @@ sendDisconnect ac mvar = do unreadVals <- DC.unreadMessageStart writeVals lengthVals <- DC.countMessages writeVals Config.traceNetIO $ show unreadVals ++ "/" ++ show lengthVals - if unreadVals >= lengthVals-1 then do + if unreadVals >= lengthVals then do Config.traceNetIO "Found a member to disconnect" - when (connectionState /= Disconnected {}) $ sendNetworkMessage ac con (Messages.Disconnect $ Data.Maybe.fromMaybe "" (ncOwnUserID con)) (-1) + case connectionState of + Connected {}-> sendNetworkMessage ac con (Messages.Disconnect $ Data.Maybe.fromMaybe "" (ncOwnUserID con)) (-1) + _ -> return () + return True else return False \ No newline at end of file diff --git a/src/Networking/DirectionalConnection.hs b/src/Networking/DirectionalConnection.hs index e92cab2..edc1c08 100644 --- a/src/Networking/DirectionalConnection.hs +++ b/src/Networking/DirectionalConnection.hs @@ -91,7 +91,7 @@ readMessageMaybe connection index = do setUnreadCount :: DirectionalConnection a -> Int -> IO () setUnreadCount connection index = do msgLength <- readMVar $ messagesCount connection - when (msgLength > index) $ do + when (msgLength >= index) $ do unreadLength <- takeMVar $ messagesUnreadStart connection if index > unreadLength then putMVar (messagesUnreadStart connection) index else putMVar (messagesUnreadStart connection) unreadLength diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 439a257..c058966 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -332,7 +332,7 @@ recieveValue = recieveValueInternal 0 val <- replaceVChanSerial activeCons vchanconsvar unclean waitUntilContactedNewPeers activeCons val ownport msgCount <- NCon.unreadMessageStart $ ncRead networkconnection - NClient.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) $ msgCount-1) 0 + NClient.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) msgCount) $ -1 return val Nothing -> if count == 0 then do msgCount <- NCon.countMessages $ ncRead networkconnection From 5eb8869af0c71eca7724828d6e805235417f6d53 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 13 Feb 2023 20:06:31 +0100 Subject: [PATCH 137/229] Fixed for simple handoff --- src/Networking/Client.hs | 7 ++----- src/Networking/Server.hs | 3 ++- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index a4b6648..ae26143 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -84,7 +84,7 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen sendingNetLog serializedMessage "Aquired connection" NC.sendMessage con message sendingNetLog serializedMessage "Sent message" - potentialResponse <- NC.recieveResponse con 10000 1000 + potentialResponse <- NC.recieveResponse con 10000 50 sendingNetLog serializedMessage "Recieved response" NC.endConversation con 10000 10 sendingNetLog serializedMessage "Ended connection" @@ -274,7 +274,6 @@ replaceVChan input = case input of sendDisconnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> IO () sendDisconnect ac mvar = do - Config.traceNetIO "Trying to disconnect all peers" networkConnectionMap <- MVar.readMVar mvar let allNetworkConnections = Map.elems networkConnectionMap goodbyes <- doForall ac allNetworkConnections @@ -293,11 +292,9 @@ sendDisconnect ac mvar = do connectionState <- MVar.readMVar $ ncConnectionState con unreadVals <- DC.unreadMessageStart writeVals lengthVals <- DC.countMessages writeVals - Config.traceNetIO $ show unreadVals ++ "/" ++ show lengthVals if unreadVals >= lengthVals then do - Config.traceNetIO "Found a member to disconnect" case connectionState of - Connected {}-> sendNetworkMessage ac con (Messages.Disconnect $ Data.Maybe.fromMaybe "" (ncOwnUserID con)) (-1) + Connected {} -> sendNetworkMessage ac con (Messages.Disconnect $ Data.Maybe.fromMaybe "" (ncOwnUserID con)) (-1) _ -> return () return True diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index c058966..59e792c 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -104,6 +104,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria NCon.changePartnerAddress networkcon clientHostaddress port connectionID SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Okay + NClient.sendNetworkMessage activeCons networkcon (Messages.AcknowledgePartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID networkcon) connectionID) 0 return Nothing AcknowledgePartnerAddress userid connectionID -> do conConfirmed <- NCon.confirmConnectionID networkcon connectionID @@ -326,7 +327,7 @@ recieveValue = recieveValueInternal 0 recieveValueInternal count vchanconsvar activeCons networkconnection ownport = do let readDC = ncRead networkconnection mbyUnclean <- DC.readUnreadMessageInterpreter readDC - Config.traceNetIO $ "Current unreadMSG:" ++ show mbyUnclean + -- Config.traceNetIO $ "Current unreadMSG:" ++ show mbyUnclean case mbyUnclean of Just unclean -> do val <- replaceVChanSerial activeCons vchanconsvar unclean From 673676117af553deb71a02031908e3b477ce63bc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 13 Feb 2023 20:24:04 +0100 Subject: [PATCH 138/229] Fixed a bug with serialization --- src/Networking/Serialize.hs | 3 ++- src/Networking/Server.hs | 5 +++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index e84fa65..eac9250 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -43,6 +43,7 @@ instance Serializable Response where Okay -> return "NOkay" OkayIntroduce u -> serializeLabeledEntry "NOkayIntroduce" u Wait -> return "NWait" + Error -> return "Error" instance Serializable Message where serialize = \case @@ -233,7 +234,7 @@ instance ((Serializable a, Serializable b, Serializable c) => Serializable (a, b ss <- serialize s ts <- serialize t vs <- serialize v - return $ "((" ++ ss ++ ") (" ++ ts ++ ") (" ++ ts ++ "))" + return $ "((" ++ ss ++ ") (" ++ ts ++ ") (" ++ vs ++ "))" instance {-# OVERLAPPING #-} Serializable PEnv where serialize arr = serializeLabeledArray "PEnv" arr diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 59e792c..d4ff0f0 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -333,12 +333,13 @@ recieveValue = recieveValueInternal 0 val <- replaceVChanSerial activeCons vchanconsvar unclean waitUntilContactedNewPeers activeCons val ownport msgCount <- NCon.unreadMessageStart $ ncRead networkconnection + Config.traceNetIO "Trying to acknowledge message" NClient.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) msgCount) $ -1 return val Nothing -> if count == 0 then do msgCount <- NCon.countMessages $ ncRead networkconnection NClient.sendNetworkMessage activeCons networkconnection (Messages.RequestValue (Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) msgCount) 0 - recieveValueInternal 10 vchanconsvar activeCons networkconnection ownport + recieveValueInternal 100 vchanconsvar activeCons networkconnection ownport else do - threadDelay 50000 + threadDelay 5000 recieveValueInternal (count-1) vchanconsvar activeCons networkconnection ownport From 2243205d7dcb204f3968dd5903205666b2d7fb5f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 13 Feb 2023 20:38:27 +0100 Subject: [PATCH 139/229] Fixed some odd design decision which could lead to wrong disconnects --- src/Networking/NetworkConnection.hs | 4 ++++ src/Networking/Server.hs | 13 +++++++++++++ 2 files changed, 17 insertions(+) diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index c9dd475..21290cb 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -1,6 +1,10 @@ module Networking.NetworkConnection where import Networking.DirectionalConnection + ( DirectionalConnection, + newConnection, + createConnection, + serializeConnection ) import Networking.UserID import qualified Data.Maybe import qualified Data.Map as Map diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index d4ff0f0..fdc77ca 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -298,12 +298,14 @@ replaceVChanSerial activeCons mvar input = case input of VChanSerial r w p o c -> do networkconnection <- createNetworkConnection r w p o c ncmap <- MVar.takeMVar mvar + {- case Map.lookup p ncmap of Just networkcon -> do connectionState <- MVar.readMVar $ ncConnectionState networkcon MVar.takeMVar $ ncConnectionState networkconnection MVar.putMVar (ncConnectionState networkconnection) connectionState Nothing -> return () + -} MVar.putMVar mvar $ Map.insert p networkconnection ncmap -- NClient.sendNetworkMessage activeCons networkconnection (RequestSync o $ length r) 5 @@ -330,8 +332,19 @@ recieveValue = recieveValueInternal 0 -- Config.traceNetIO $ "Current unreadMSG:" ++ show mbyUnclean case mbyUnclean of Just unclean -> do + Config.traceNetIO "Preparing value" + uncleanser <- NSerialize.serialize unclean + Config.traceNetIO uncleanser val <- replaceVChanSerial activeCons vchanconsvar unclean + cleanser <- NSerialize.serialize val + Config.traceNetIO cleanser waitUntilContactedNewPeers activeCons val ownport + case val of + VChan nc _ -> do + connectionState <- MVar.readMVar $ ncConnectionState nc + Config.traceNetIO $ show connectionState + _ -> return () + msgCount <- NCon.unreadMessageStart $ ncRead networkconnection Config.traceNetIO "Trying to acknowledge message" NClient.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) msgCount) $ -1 From 7f14e448c1c4f15f39766bf98161481d035b1a8e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 13 Feb 2023 21:01:26 +0100 Subject: [PATCH 140/229] Seems to be somewhat stable now --- src/Networking/Client.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index ae26143..064cf93 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -274,6 +274,7 @@ replaceVChan input = case input of sendDisconnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> IO () sendDisconnect ac mvar = do + Config.traceNetIO "sendDisconnect" networkConnectionMap <- MVar.readMVar mvar let allNetworkConnections = Map.elems networkConnectionMap goodbyes <- doForall ac allNetworkConnections @@ -292,10 +293,9 @@ sendDisconnect ac mvar = do connectionState <- MVar.readMVar $ ncConnectionState con unreadVals <- DC.unreadMessageStart writeVals lengthVals <- DC.countMessages writeVals - if unreadVals >= lengthVals then do - case connectionState of - Connected {} -> sendNetworkMessage ac con (Messages.Disconnect $ Data.Maybe.fromMaybe "" (ncOwnUserID con)) (-1) - _ -> return () - - return True - else return False \ No newline at end of file + Config.traceNetIO $ show unreadVals ++ "/" ++ show lengthVals + case connectionState of + Connected {} -> if unreadVals >= lengthVals then do + sendNetworkMessage ac con (Messages.Disconnect $ Data.Maybe.fromMaybe "" (ncOwnUserID con)) (-1) + return True else return False + _ -> return True \ No newline at end of file From aa6ef8e07fe641d1805d81db18831bf367f2b0ba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 13 Feb 2023 23:43:48 +0100 Subject: [PATCH 141/229] Fixed order of which a new client is added to ldgvnw Fixed an issue where a client was added to the clientlist before being added to the list of networkconnections --- src/Networking/Client.hs | 4 ++-- src/Networking/Server.hs | 30 +++++++++--------------------- testNWCountHigh.sh | 2 +- 3 files changed, 12 insertions(+), 24 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 064cf93..43d2762 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -274,7 +274,7 @@ replaceVChan input = case input of sendDisconnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> IO () sendDisconnect ac mvar = do - Config.traceNetIO "sendDisconnect" + --Config.traceNetIO "sendDisconnect" networkConnectionMap <- MVar.readMVar mvar let allNetworkConnections = Map.elems networkConnectionMap goodbyes <- doForall ac allNetworkConnections @@ -293,7 +293,7 @@ sendDisconnect ac mvar = do connectionState <- MVar.readMVar $ ncConnectionState con unreadVals <- DC.unreadMessageStart writeVals lengthVals <- DC.countMessages writeVals - Config.traceNetIO $ show unreadVals ++ "/" ++ show lengthVals + --Config.traceNetIO $ show unreadVals ++ "/" ++ show lengthVals case connectionState of Connected {} -> if unreadVals >= lengthVals then do sendNetworkMessage ac con (Messages.Disconnect $ Data.Maybe.fromMaybe "" (ncOwnUserID con)) (-1) diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index fdc77ca..d25e6c9 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -63,7 +63,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria return "" netcons <- MVar.readMVar mvar - newnetcon <- case Map.lookup userid netcons of + case Map.lookup userid netcons of Just networkcon -> do recievedNetLog message $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " (" ++ ownport ++ ") from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) -- Config.traceNetIO $ " "++message @@ -77,7 +77,6 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria recievedNetLog message $ "Send redirect to:" ++ host ++ ":" ++ port SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl (Messages.Redirect host port) - return Nothing Connected {} -> case deserialmessages of NewValue userid count val -> do ND.lockInterpreterReads (ncRead networkcon) @@ -87,52 +86,43 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria NC.sendResponse hdl Messages.Okay recievedNetLog message "Sent okay" ND.unlockInterpreterReads (ncRead networkcon) - return Nothing RequestValue userid count -> do SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Okay mbyval <- DC.readMessageMaybe (NCon.ncWrite networkcon) count Data.Maybe.maybe (return ()) (\val -> NClient.sendNetworkMessage activeCons networkcon (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkcon) count val) 0) mbyval - return Nothing AcknowledgeValue userid count -> do DC.setUnreadCount (NCon.ncWrite networkcon) count SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Okay - return Nothing NewPartnerAddress userid port connectionID -> do recievedNetLog message $ "Trying to change the address to: " ++ clientHostaddress ++ ":" ++ port NCon.changePartnerAddress networkcon clientHostaddress port connectionID SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Okay NClient.sendNetworkMessage activeCons networkcon (Messages.AcknowledgePartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID networkcon) connectionID) 0 - return Nothing AcknowledgePartnerAddress userid connectionID -> do conConfirmed <- NCon.confirmConnectionID networkcon connectionID SSem.signal $ ncHandlingIncomingMessage networkcon if conConfirmed then NC.sendResponse hdl Messages.Okay else NC.sendResponse hdl Messages.Error - return Nothing Disconnect userid -> do NCon.disconnectFromPartner networkcon SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Okay - return Nothing _ -> do serial <- NSerialize.serialize deserialmessages recievedNetLog message $ "Error unsupported networkmessage: "++ serial SSem.signal $ ncHandlingIncomingMessage networkcon - NC.sendResponse hdl Messages.Okay - return Nothing + NC.sendResponse hdl Messages.Okay _ -> do recievedNetLog message "Network Connection is in a illegal state!" SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Okay - return Nothing return reply Nothing -> do recievedNetLog message "Message cannot be handled at the moment! Sending wait response" SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Wait - return Nothing Nothing -> do recievedNetLog message "Recieved message from unknown connection" @@ -144,23 +134,21 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria repserial <- NSerialize.serialize $ Messages.OkayIntroduce serverid recievedNetLog message $ " Response to "++ userid ++ ": " ++ repserial + recievedNetLog message "Patching MVar" + netcons <- MVar.takeMVar mvar + MVar.putMVar mvar $ Map.insert userid newpeer netcons + + clientlistraw <- MVar.takeMVar clientlist MVar.putMVar clientlist $ clientlistraw ++ [(userid, (synname, syntype))] - - return $ Just newpeer + -- We must not write clients into the clientlist before adding them to the networkconnectionmap _ -> do serial <- NSerialize.serialize deserialmessages recievedNetLog message $ "Error unsupported networkmessage: "++ serial recievedNetLog message "This is probably a timing issue! Lets resend later" NC.sendResponse hdl Messages.Wait - return Nothing - recievedNetLog message "Patching MVar" - case newnetcon of - Just newnet -> do - netcons <- MVar.takeMVar mvar - MVar.putMVar mvar $ Map.insert userid newnet netcons - Nothing -> return () + recievedNetLog message "Message successfully handled" recievedNetLog :: String -> String -> IO () diff --git a/testNWCountHigh.sh b/testNWCountHigh.sh index cc815c8..0e5a764 100644 --- a/testNWCountHigh.sh +++ b/testNWCountHigh.sh @@ -1,4 +1,4 @@ -for i in {1..20000}; do +for i in {1..200000}; do clear; echo "$i Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/add/server.ldgvnw & stack run ldgv -- interpret < dev-examples/add/client.ldgvnw & wait); clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/simple/server.ldgvnw & stack run ldgv -- interpret < dev-examples/simple/client.ldgvnw & wait); clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirectional/client.ldgvnw & wait); From bca46bff58474eed731f5855eeccf97d616a9283 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 14 Feb 2023 09:34:42 +0100 Subject: [PATCH 142/229] This version seems stable 5700 successful runs of all 8 tests --- testNWCountHigh.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/testNWCountHigh.sh b/testNWCountHigh.sh index 0e5a764..cc815c8 100644 --- a/testNWCountHigh.sh +++ b/testNWCountHigh.sh @@ -1,4 +1,4 @@ -for i in {1..200000}; do +for i in {1..20000}; do clear; echo "$i Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/add/server.ldgvnw & stack run ldgv -- interpret < dev-examples/add/client.ldgvnw & wait); clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/simple/server.ldgvnw & stack run ldgv -- interpret < dev-examples/simple/client.ldgvnw & wait); clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirectional/client.ldgvnw & wait); From 42191746ff78457cd2ffb81d265c95b8628d1973 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 14 Feb 2023 12:02:29 +0100 Subject: [PATCH 143/229] Fixed hypothetical race condition 560 successful runs; manually halted --- src/Networking/Client.hs | 52 +++++++++++++++++++++++++++++----------- src/Networking/Server.hs | 6 +++-- 2 files changed, 42 insertions(+), 16 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 43d2762..8e72107 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -42,7 +42,7 @@ instance Show ClientException where instance Exception ClientException -sendValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> Value -> String -> Int -> IO () +sendValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> Value -> String -> Int -> IO Bool sendValue vchanconsmvar activeCons networkconnection val ownport resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of @@ -60,20 +60,28 @@ sendValue vchanconsmvar activeCons networkconnection val ownport resendOnError = let partnerid = Data.Maybe.fromMaybe "" $ ncPartnerUserID networkconnection let mbypartner = Map.lookup partnerid vchancons case mbypartner of - Just partner -> DC.writeMessage (ncRead partner) valCleaned - _ -> Config.traceNetIO "Something went wrong when sending over a emulated connection" + Just partner -> do + DC.writeMessage (ncRead partner) valCleaned + return True + _ -> do + Config.traceNetIO "Something went wrong when sending over a emulated connection" + return False -- disableVChans val - _ -> Config.traceNetIO "Error when sending message: This channel is disconnected" + _ -> do + Config.traceNetIO "Error when sending message: This channel is disconnected" + return False -sendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> Message -> Int -> IO () +sendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> Message -> Int -> IO Bool sendNetworkMessage activeCons networkconnection message resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of NCon.Connected hostname port _ _ _ -> do tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError - _ -> Config.traceNetIO "Error when sending message: This channel is disconnected" + _ -> do + Config.traceNetIO "Error when sending message: This channel is disconnected" + return False -tryToSendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> String -> String -> Message -> Int -> IO () +tryToSendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> String -> String -> Message -> Int -> IO Bool tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError = do serializedMessage <- NSerialize.serialize message sendingNetLog serializedMessage $ "Sending message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection) ++ " to: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkconnection) ++ " Over: " ++ hostname ++ ":" ++ port @@ -93,9 +101,11 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen sendingNetLog serializedMessage "Connecting unsuccessful" return Nothing - case mbyresponse of + success <- case mbyresponse of Just response -> case response of - Okay -> sendingNetLog serializedMessage "Message okay" + Okay -> do + sendingNetLog serializedMessage "Message okay" + return True Redirect host port -> do sendingNetLog serializedMessage "Communication partner changed address, resending" -- NCon.changePartnerAddress networkconnection host port "" -- TODO properly fix this @@ -104,11 +114,22 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen sendingNetLog serializedMessage "Communication out of sync lets wait!" threadDelay 1000000 tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError - _ -> sendingNetLog serializedMessage "Unknown communication error" + _ -> do + sendingNetLog serializedMessage "Unknown communication error" + return False Nothing -> do sendingNetLog serializedMessage "Error when recieving response" + if resendOnError /= 0 then do + connectionState <- MVar.readMVar $ ncConnectionState networkconnection + case connectionState of + Connected updatedhost updatedport _ _ _ -> do + sendingNetLog serializedMessage $ "Trying to resend to: " ++ updatedhost ++ ":" ++ updatedport + tryToSendNetworkMessage activeCons networkconnection updatedhost updatedport message $ max (resendOnError-1) (-1) + _ -> return False + else return False sendingNetLog serializedMessage "Message got send or finally failed!" + return success sendingNetLog :: String -> String -> IO () @@ -145,8 +166,10 @@ setPartnerHostAddress address input = case input of (fst x, newval):setPartnerHostAddressPEnv clientHostaddress xs -} -printConErr :: String -> String -> IOException -> IO () -printConErr hostname port err = Config.traceIO $ "Communication Partner " ++ hostname ++ ":" ++ port ++ "not found!" +printConErr :: String -> String -> IOException -> IO Bool +printConErr hostname port err = do + Config.traceIO $ "Communication Partner " ++ hostname ++ ":" ++ port ++ "not found! \n " ++ show err + return False initialConnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> String -> String -> String -> (Syntax.Type, Syntax.Type) -> IO Value @@ -295,7 +318,8 @@ sendDisconnect ac mvar = do lengthVals <- DC.countMessages writeVals --Config.traceNetIO $ show unreadVals ++ "/" ++ show lengthVals case connectionState of - Connected {} -> if unreadVals >= lengthVals then do - sendNetworkMessage ac con (Messages.Disconnect $ Data.Maybe.fromMaybe "" (ncOwnUserID con)) (-1) + Connected host port _ _ _ -> if unreadVals >= lengthVals then do + + catch (sendNetworkMessage ac con (Messages.Disconnect $ Data.Maybe.fromMaybe "" (ncOwnUserID con)) 0) $ printConErr host port return True else return False _ -> return True \ No newline at end of file diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index d25e6c9..8fe7fba 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -90,17 +90,19 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Okay mbyval <- DC.readMessageMaybe (NCon.ncWrite networkcon) count - Data.Maybe.maybe (return ()) (\val -> NClient.sendNetworkMessage activeCons networkcon (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkcon) count val) 0) mbyval + Data.Maybe.maybe (return False) (\val -> NClient.sendNetworkMessage activeCons networkcon (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkcon) count val) 0) mbyval + return () AcknowledgeValue userid count -> do + NC.sendResponse hdl Messages.Okay -- This okay is needed here to fix a race-condition with disconnects being faster than the okay DC.setUnreadCount (NCon.ncWrite networkcon) count SSem.signal $ ncHandlingIncomingMessage networkcon - NC.sendResponse hdl Messages.Okay NewPartnerAddress userid port connectionID -> do recievedNetLog message $ "Trying to change the address to: " ++ clientHostaddress ++ ":" ++ port NCon.changePartnerAddress networkcon clientHostaddress port connectionID SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Okay NClient.sendNetworkMessage activeCons networkcon (Messages.AcknowledgePartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID networkcon) connectionID) 0 + return () AcknowledgePartnerAddress userid connectionID -> do conConfirmed <- NCon.confirmConnectionID networkcon connectionID SSem.signal $ ncHandlingIncomingMessage networkcon From c0cc095373cafea740a4c4e726cbb9f3e3338cd6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 14 Feb 2023 15:13:00 +0100 Subject: [PATCH 144/229] Fixed stack test and sending emulated chans --- src/Interpreter.hs | 3 -- src/Networking/Client.hs | 5 ++-- src/Networking/Server.hs | 60 ++++++++++++++++++++++++++++++++++------ testLDGVTests.sh | 21 ++++++++++++++ testNWCount.sh | 3 +- testNWCountHigh.sh | 1 + 6 files changed, 78 insertions(+), 15 deletions(-) create mode 100644 testLDGVTests.sh diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 494412d..72116c9 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -203,10 +203,7 @@ eval = \case interpret' e >>= \v@(VChan ci usedmvar) -> do used <- liftIO $ MVar.readMVar usedmvar if used then throw $ VChanIsUsedException $ show v else do - let dcRead = NCon.ncRead ci - -- valunclean <- liftIO $ DC.readUnreadMessageInterpreter dcRead (env, (sockets, vchanconnections, activeConnections)) <- ask - -- val <- liftIO $ NS.replaceVChanSerial activeConnections vchanconnections valunclean socketsraw <- liftIO $ MVar.readMVar sockets let port = show $ head $ Map.keys socketsraw val <- liftIO $ NS.recieveValue vchanconnections activeConnections ci port diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 8e72107..e6d9dff 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -57,8 +57,8 @@ sendValue vchanconsmvar activeCons networkconnection val ownport resendOnError = vchancons <- MVar.readMVar vchanconsmvar valCleaned <- replaceVChan val DC.writeMessage (ncWrite networkconnection) valCleaned - let partnerid = Data.Maybe.fromMaybe "" $ ncPartnerUserID networkconnection - let mbypartner = Map.lookup partnerid vchancons + let ownid = Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection + let mbypartner = Map.lookup ownid vchancons case mbypartner of Just partner -> do DC.writeMessage (ncRead partner) valCleaned @@ -77,6 +77,7 @@ sendNetworkMessage activeCons networkconnection message resendOnError = do case connectionstate of NCon.Connected hostname port _ _ _ -> do tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError + NCon.Emulated {} -> return True _ -> do Config.traceNetIO "Error when sending message: This channel is disconnected" return False diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 8fe7fba..c6df42a 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -80,7 +80,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria Connected {} -> case deserialmessages of NewValue userid count val -> do ND.lockInterpreterReads (ncRead networkcon) - ND.writeMessageIfNext (ncRead networkcon) count val + ND.writeMessageIfNext (ncRead networkcon) count $ setPartnerHostAddress clientHostaddress val SSem.signal $ ncHandlingIncomingMessage networkcon recievedNetLog message "Message written to Channel" NC.sendResponse hdl Messages.Okay @@ -157,7 +157,7 @@ recievedNetLog :: String -> String -> IO () recievedNetLog msg info = Config.traceNetIO $ "Recieved message: "++msg++" \n Status: "++info -{- + setPartnerHostAddress :: String -> Value -> Value setPartnerHostAddress address input = case input of VSend v -> VSend $ setPartnerHostAddress address v @@ -177,8 +177,8 @@ setPartnerHostAddress address input = case input of let newpenv = setPartnerHostAddressPEnv address penv in VNewNatRec newpenv a b c d e f g VChanSerial r w p o c -> do - let (hostname, port) = c - VChanSerial r w p o (if hostname == "" then address else hostname, port) + let (hostname, port, partnerID) = c + VChanSerial r w p o (if hostname == "" then address else hostname, port, partnerID) _ -> input -- return input where setPartnerHostAddressPEnv :: String -> [(String, Value)] -> [(String, Value)] @@ -186,7 +186,6 @@ setPartnerHostAddress address input = case input of setPartnerHostAddressPEnv clientHostaddress penvs@(x:xs) = let newval = setPartnerHostAddress clientHostaddress $ snd x in (fst x, newval):setPartnerHostAddressPEnv clientHostaddress xs --} waitUntilContactedNewPeers :: NMC.ActiveConnections -> Value -> String -> IO () waitUntilContactedNewPeers activeCons input ownport = do @@ -216,9 +215,12 @@ contactNewPeers activeCons input ownport = case input of contactNewPeersPEnv activeCons penv ownport VChan nc bool -> do connectionState <- MVar.readMVar $ ncConnectionState nc - if csConfirmedConnection connectionState then return True else do - NClient.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) 0 - return False + case connectionState of + Emulated {} -> return True + _ -> do + if csConfirmedConnection connectionState then return True else do + NClient.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) 0 + return False _ -> return True where contactNewPeersPEnv :: NMC.ActiveConnections -> [(String, Value)] -> String -> IO Bool -- [(String, Value)] @@ -313,7 +315,11 @@ replaceVChanSerial activeCons mvar input = case input of recieveValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value -recieveValue = recieveValueInternal 0 +recieveValue vchanconsvar activeCons networkconnection ownport = do + connectionState <- MVar.readMVar $ ncConnectionState networkconnection + case connectionState of + Emulated {} -> recieveValueEmulated vchanconsvar activeCons networkconnection ownport + _ -> recieveValueInternal 0 vchanconsvar activeCons networkconnection ownport where recieveValueInternal :: Int -> VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value recieveValueInternal count vchanconsvar activeCons networkconnection ownport = do @@ -346,3 +352,39 @@ recieveValue = recieveValueInternal 0 else do threadDelay 5000 recieveValueInternal (count-1) vchanconsvar activeCons networkconnection ownport + recieveValueEmulated :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value + recieveValueEmulated vchanconsvar activeCons networkconnection ownport = do + let readDC = ncRead networkconnection + mbyUnclean <- DC.readUnreadMessageInterpreter readDC + -- allValues <- DC.allMessages $ ncWrite networkconnection + -- Config.traceNetIO $ "all Values: "++ show allValues + case mbyUnclean of + Just unclean -> do + Config.traceNetIO "Preparing value" + uncleanser <- NSerialize.serialize unclean + Config.traceNetIO uncleanser + val <- replaceVChanSerial activeCons vchanconsvar unclean + cleanser <- NSerialize.serialize val + Config.traceNetIO cleanser + waitUntilContactedNewPeers activeCons val ownport + case val of + VChan nc _ -> do + connectionState <- MVar.readMVar $ ncConnectionState nc + Config.traceNetIO $ show connectionState + _ -> return () + + msgCount <- NCon.unreadMessageStart $ ncRead networkconnection + Config.traceNetIO "Trying to acknowledge message" + vchancons <- MVar.readMVar vchanconsvar + let partnerid = Data.Maybe.fromMaybe "" $ ncPartnerUserID networkconnection + let mbypartner = Map.lookup partnerid vchancons + case mbypartner of + Just partner -> do + DC.setUnreadCount (ncRead partner) msgCount + _ -> Config.traceNetIO "Something went wrong when acknowleding value of emulated connection" + + return val + Nothing -> do + threadDelay 5000 + recieveValueEmulated vchanconsvar activeCons networkconnection ownport + diff --git a/testLDGVTests.sh b/testLDGVTests.sh new file mode 100644 index 0000000..9fc4360 --- /dev/null +++ b/testLDGVTests.sh @@ -0,0 +1,21 @@ +clear; echo "add"; stack run ldgv -- interpret < examples/add.ldgv +clear; echo "case-singleton"; stack run ldgv -- interpret < examples/case-singleton.ldgv +clear; echo "casesub"; stack run ldgv -- interpret < examples/casesub.ldgv +clear; echo "casetest"; stack run ldgv -- interpret < examples/casetest.ldgv +clear; echo "casts"; stack run ldgv -- interpret < examples/casts.ccldgv +clear; echo "depcast"; stack run ldgv -- interpret < examples/depcast.ccldgv +clear; echo "depsum"; stack run ldgv -- interpret < examples/depsum.ldgv +clear; echo "just-f2"; stack run ldgv -- interpret < examples/just-f2.ccldgv +clear; echo "just-f3"; stack run ldgv -- interpret < examples/just-f3.ccldgv +clear; echo "mymap"; stack run ldgv -- interpret < examples/mymap.gldgv +clear; echo "natsum"; stack run ldgv -- interpret < examples/natsum.ldgv +clear; echo "natsum2-new"; stack run ldgv -- interpret < examples/natsum2-new.ldgv +clear; echo "natsum2-rec"; stack run ldgv -- interpret < examples/natsum2-rec.ldgv +clear; echo "natsum2"; stack run ldgv -- interpret < examples/natsum2.ldgv +clear; echo "node"; stack run ldgv -- interpret < examples/node.ldgv +clear; echo "noderec"; stack run ldgv -- interpret < examples/noderec.ldgv +clear; echo "person"; stack run ldgv -- interpret < examples/person.gldgv +clear; echo "simple_recursion"; stack run ldgv -- interpret < examples/simple_recursion.ldgv +clear; echo "simple"; stack run ldgv -- interpret < examples/simple.ldgv +# clear; echo "tclient"; stack run ldgv -- interpret < examples/tclient.ldgv +# clear; echo "tserver"; stack run ldgv -- interpret < examples/tserver.ldgv \ No newline at end of file diff --git a/testNWCount.sh b/testNWCount.sh index 762cda4..3522047 100644 --- a/testNWCount.sh +++ b/testNWCount.sh @@ -5,6 +5,7 @@ for i in {1..1000}; do clear; echo "$i Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff/client.ldgvnw & wait); clear; echo "$i Handoff2"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/client.ldgvnw & wait); clear; echo "$i Handoff3"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff3/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/client.ldgvnw & wait); - clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/client.ldgvnw & wait); + clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/client.ldgvnw & wait); + clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff5/handoff.ldgvnw & wait); clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/client.ldgvnw & wait); done \ No newline at end of file diff --git a/testNWCountHigh.sh b/testNWCountHigh.sh index cc815c8..52a4fc2 100644 --- a/testNWCountHigh.sh +++ b/testNWCountHigh.sh @@ -6,5 +6,6 @@ for i in {1..20000}; do clear; echo "$i Handoff2"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/client.ldgvnw & wait); clear; echo "$i Handoff3"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff3/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/client.ldgvnw & wait); clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/client.ldgvnw & wait); + clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff5/handoff.ldgvnw & wait); clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/client.ldgvnw & wait); done \ No newline at end of file From a24b7f5eec193b2cd62957f36508fb057009d5c1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 14 Feb 2023 16:27:00 +0100 Subject: [PATCH 145/229] Removed unnecessary code --- log/FastNetworkingBug.log | 997 ------------------ log/FastNetworkingBug2.log | 927 ---------------- log/FastNetworkingBug3.log | 706 ------------- log/FastNetworkingBug4.log | 386 ------- log/FastNetworkingBug5.log | 386 ------- log/FastNetworkingBug6.log | 568 ---------- src/Networking/Client.hs | 65 +- src/Networking/Common.hs | 9 - src/Networking/DirectionalConnection.hs | 3 +- src/Networking/NetworkingMethod/Fast.hs | 35 +- .../NetworkingMethodCommon.hs | 2 +- src/Networking/NetworkingMethod/Stateless.hs | 19 +- src/Networking/Serialize.hs | 6 - src/Networking/Server.hs | 42 +- src/Networking/UserID.hs | 1 - 15 files changed, 20 insertions(+), 4132 deletions(-) delete mode 100644 log/FastNetworkingBug.log delete mode 100644 log/FastNetworkingBug2.log delete mode 100644 log/FastNetworkingBug3.log delete mode 100644 log/FastNetworkingBug4.log delete mode 100644 log/FastNetworkingBug5.log delete mode 100644 log/FastNetworkingBug6.log diff --git a/log/FastNetworkingBug.log b/log/FastNetworkingBug.log deleted file mode 100644 index 81d42be..0000000 --- a/log/FastNetworkingBug.log +++ /dev/null @@ -1,997 +0,0 @@ -1051 Bidirhandoff -subtype: Entering [(c, (0, SendInt))] (Nat) (Int) -subtype: Entering [ (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Nat) (Int) -subtype: Entering [ (y2, (_, ())) -, (m, (_, Int)) -, (y, (0, ?Int. ())) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Int) (Int) -subtype: Entering [(c, (0, SendInt))] (Nat) (Int) -subtype: Entering [ (y2, (_, ())) -, (m, (_, Int)) -, (y, (0, ?Int. ())) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Int) (Int) -subtype: Entering [ (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (c32, (_, ())) -, (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: Entering [ (c32, (_, ())) -, (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: Entering [ (y, (_, ())) -, (talk, (0, SendIntClient)) -, (con, (0, ~SendSendIntClient)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: Entering [ (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Nat) (Int) -subtype: Entering [ (y2, (_, ())) -, (m, (_, Int)) -, (y, (0, ?Int. ())) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Int) (Int) -subtype: Entering [(c, (0, SendInt))] (Nat) (Int) -subtype: Entering [ (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Nat) (Int) -subtype: Entering [ (y2, (_, ())) -, (m, (_, Int)) -, (y, (0, ?Int. ())) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Int) (Int) -subtype: Entering [ (y2, (_, ())) -, (m, (_, Int)) -, (y, (0, ?Int. ())) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Int) (Int) -subtype: Entering [ (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (c32, (_, ())) -, (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: Entering [ (c32, (_, ())) -, (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: Entering [ (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (con, (0, ~SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (con2, (0, SendSendIntServer)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (con, (0, ~SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (?Int. !Int. ()) (SendIntServer) -subtype: Entering [ (con2, (0, SendSendIntServer)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (con, (0, ~SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (?Int. !Int. ()) (?Int. !Int. ()) -subtype: Entering [ (con2, (0, SendSendIntServer)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (con, (0, ~SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: [ (con2, (0, SendSendIntServer)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (con, (0, ~SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) = Kunit -subtype: Entering [ (zz8, (_, Int)) -, (con2, (0, SendSendIntServer)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (con, (0, ~SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (!Int. ()) (!Int. ()) -subtype: Entering [ (zz8, (_, Int)) -, (con2, (0, SendSendIntServer)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (con, (0, ~SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: [ (zz8, (_, Int)) -, (con2, (0, SendSendIntServer)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (con, (0, ~SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) = Kunit -subtype: Entering [ (zz9, (_, Int)) -, (zz8, (_, Int)) -, (con2, (0, SendSendIntServer)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (con, (0, ~SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (()) (()) -subtype: Entering [ (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: Entering [ (y2, (_, ())) -, (m, (_, Int)) -, (y, (0, ?Int. ())) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Int) (Int) -subtype: Entering [ (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (c32, (_, ())) -, (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: Entering [ (c32, (_, ())) -, (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: Entering [ (con, (0, SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (con2, (0, SendSendIntClient)) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (con, (0, SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (!Int. ?Int. ()) (SendIntClient) -subtype: Entering [ (con2, (0, SendSendIntClient)) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (con, (0, SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (!Int. ?Int. ()) (!Int. ?Int. ()) -subtype: Entering [ (con2, (0, SendSendIntClient)) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (con, (0, SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: [ (con2, (0, SendSendIntClient)) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (con, (0, SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) = Kunit -subtype: Entering [ (zz8, (_, Int)) -, (con2, (0, SendSendIntClient)) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (con, (0, SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (?Int. ()) (?Int. ()) -subtype: Entering [ (zz8, (_, Int)) -, (con2, (0, SendSendIntClient)) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (con, (0, SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: [ (zz8, (_, Int)) -, (con2, (0, SendSendIntClient)) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (con, (0, SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) = Kunit -subtype: Entering [ (zz9, (_, Int)) -, (zz8, (_, Int)) -, (con2, (0, SendSendIntClient)) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (con, (0, SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (()) (()) -subtype: Entering [ (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -Trying to connect to: 127.0.0.1:4242 -subtype: Entering [(c, (0, SendInt))] (Nat) (Int) -subtype: Entering [ (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Nat) (Int) -subtype: Entering [ (y2, (_, ())) -, (m, (_, Int)) -, (y, (0, ?Int. ())) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Int) (Int) -Client connected: Introducing -Client connected: send message -Recieved message from unknown connection! - Response to nSmP4vJF: NOkayIntroduce (String:"y0loScB1") - Message: NConversationMessage (String:"KgNtutI8") (NIntroduceClient (String:"nSmP4vJF") (String:"4343") (TName (Bool:False) (String:"SendInt"))) -subtype: Entering [ (y2, (_, ())) -, (m, (_, Int)) -, (y, (0, ?Int. ())) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Int) (Int) -subtype: Entering [ (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (c32, (_, ())) -, (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: Entering [ (c32, (_, ())) -, (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: Entering [ (c2, (0, !Int. ())) -, (m, (_, Int)) -, (c1, (_, ())) -, (talk, (0, SendIntServer)) -, (con, (0, ~SendSendIntServer)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -Trying to connect to: 127.0.0.1:4242 -Client connected: got answer -Client disconnected! -Finished Handshake -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceClient (String:"nSmP4vJF") (String:"4343") (TName (Bool:False) (String:"SendInt")) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NNewValue (String:"nSmP4vJF") (Int:1) (VInt (Int:1)) -Client connected: Introducing -Client connected: send message -Recieved message from unknown connection! - Response to 9o1aHTcp: NOkayIntroduce (String:"FxLP6Xqs") - Message: NConversationMessage (String:"JlhXySIQ") (NIntroduceClient (String:"9o1aHTcp") (String:"4240") (TName (Bool:True) (String:"SendSendIntServer"))) -Client connected: got answer -Client disconnected! -Finished Handshake -Sending message as: 9o1aHTcp to: FxLP6Xqs - Over: 127.0.0.1:4242 - Message: NIntroduceClient (String:"9o1aHTcp") (String:"4240") (TName (Bool:True) (String:"SendSendIntServer")) -Recieved message as: y0loScB1 (4242) from: nSmP4vJF - Message: NConversationMessage (String:"6d2mTsHp") (NNewValue (String:"nSmP4vJF") (Int:1) (VInt (Int:1))) -Sending message as: y0loScB1 to: nSmP4vJF - Over: 127.0.0.1:4343 - Message: NNewValue (String:"y0loScB1") (Int:1) (VInt (Int:1300)) -Trying to connect to: 127.0.0.1:4343 -Recieved message as: nSmP4vJF (4343) from: y0loScB1 - Message: NConversationMessage (String:"OdtXfcAm") (NNewValue (String:"y0loScB1") (Int:1) (VInt (Int:1300))) -Message okay: NNewValue (String:"y0loScB1") (Int:1) (VInt (Int:1300)) -Set RedirectRequest for nSmP4vJF to 127.0.0.1:4240 -Sending message as: FxLP6Xqs to: 9o1aHTcp - Over: 127.0.0.1:4240 - Message: NNewValue (String:"FxLP6Xqs") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray [VInt (Int:1300)]) (Int:0))) (String:"nSmP4vJF") (String:"y0loScB1") (((String:"127.0.0.1") (String:"4343")))) -Trying to connect to: 127.0.0.1:4240 -Recieved message as: 9o1aHTcp (4240) from: FxLP6Xqs -Sending message as: y0loScB1 to: nSmP4vJF - Over: 127.0.0.1:4343 - Message: NIntroduceNewPartnerAddress (String:"y0loScB1") (String:"4240") -Trying to connect to: 127.0.0.1:4343 -Sending message as: y0loScB1 to: nSmP4vJF - Over: 127.0.0.1:4343 -Message okay: NNewValue (String:"nSmP4vJF") (Int:1) (VInt (Int:1)) -Trying to connect to: 127.0.0.1:4340 - Message: NRequestSync (String:"y0loScB1") -Client connected: Introducing -Client connected: send message -Recieved message from unknown connection! - Response to m58eVfxV: NOkayIntroduce (String:"BV7wLFBf") - Message: NConversationMessage (String:"VTxR2xzx") (NIntroduceClient (String:"m58eVfxV") (String:"4343") (TName (Bool:False) (String:"SendSendIntClient"))) -Client connected: got answer -Client disconnected! -Finished Handshake -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 -Recieved message as: nSmP4vJF (4343) from: y0loScB1 - Message: NIntroduceClient (String:"m58eVfxV") (String:"4343") (TName (Bool:False) (String:"SendSendIntClient")) -Set RedirectRequest for y0loScB1 to 127.0.0.1:4340 -Took MVar for message: NConversationMessage (String:"KlPvDlGO") (NIntroduceNewPartnerAddress (String:"y0loScB1") (String:"4240")) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 -Trying to change the address to: 127.0.0.1:4240 -Put MVar for message: NConversationMessage (String:"KlPvDlGO") (NIntroduceNewPartnerAddress (String:"y0loScB1") (String:"4240")) - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) - Message: NConversationMessage (String:"KlPvDlGO") (NIntroduceNewPartnerAddress (String:"y0loScB1") (String:"4240")) -Recieved message as: nSmP4vJF (4343) from: y0loScB1 - Message: NConversationMessage (String:"7FR8CTTZ") (NRequestSync (String:"y0loScB1")) -Message okay: NIntroduceNewPartnerAddress (String:"y0loScB1") (String:"4240") - Message: NConversationMessage (String:"4fMWxwW4") (NNewValue (String:"FxLP6Xqs") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray [VInt (Int:1300)]) (Int:0))) (String:"nSmP4vJF") (String:"y0loScB1") (((String:"127.0.0.1") (String:"4343"))))) -Message okay: NRequestSync (String:"y0loScB1") -Got syncronization values: NOkaySync (SValuesArray [VInt (Int:1)]) -Message okay: NNewValue (String:"FxLP6Xqs") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray [VInt (Int:1300)]) (Int:0))) (String:"nSmP4vJF") (String:"y0loScB1") (((String:"127.0.0.1") (String:"4343")))) -Result: VInt 1 -ldgv: ldgv: : hGetLine: end of file -ldgv: : hGetLine: end of file -: hGetLine: end of fileldgv: : hGetLine: end of file - -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"nSmP4vJF") -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying -Trying to connect to: 127.0.0.1:4242 - Message: NConversationMessage (String:"TwS8y4jm") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Error when recieving response -Not connected to peer -Original message: NRequestSync (String:"nSmP4vJF") -Old communication partner offline! No longer retrying -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NNewValue (String:"nSmP4vJF") (Int:2) (VInt (Int:41)) -Trying to connect to: 127.0.0.1:4343 -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"BjdQRFgC") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NNewValue (String:"nSmP4vJF") (Int:2) (VInt (Int:41)) -Old communication partner offline! No longer retrying -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"UohqDYdS") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"GXNfJ7Yw") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"mDHQVSsA") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"XBxE6x6Y") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"FTezMCeI") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"HUL61CKa") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"WQwkpcTa") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"7CVpX7do") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"AlmTbNsu") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"dYvESZX1") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"5KI6rVpR") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"0EVbl7T6") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"zSAFR5ts") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"8XkNpQe4") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"E1QJbkIL") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"o2RMmriL") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"S1Rn7sOh") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"HjEwIYxC") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"yK7csElA") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"6xOE3t5Q") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"meKpjxJS") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"vPKDc5pN") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"Xh73nNHw") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"azJlN8EX") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"S2f1pHZk") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"FhGxPvQH") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"cPVqHGxm") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"sas5N9Tn") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"xXZHSQh7") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"dCpN5qnB") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"UVwrVwJa") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"npIaTvHJ") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"n3z3MXoW") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"ZzZzogKm") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"f1Uzlhwi") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"jQhzGDo9") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"qcxr5O8Z") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"ZLaI4TPK") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"ubQkIvZ3") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"tDK1U5SP") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -Error when recieving response -Original message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Old communication partner offline! New communication partner: 127.0.0.1:4340 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"z8xMNkdk") (NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: m58eVfxV to: BV7wLFBf - Over: 127.0.0.1:4340 - Message: NNewValue (String:"m58eVfxV") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: BV7wLFBf (4340) from: m58eVfxV -Sending message as: BV7wLFBf to: m58eVfxV - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"BV7wLFBf") -Recieved message as: m58eVfxV (4343) from: BV7wLFBf - Message: NConversationMessage (String:"xaLWO908") (NRequestSync (String:"BV7wLFBf")) -Message okay: NRequestSync (String:"BV7wLFBf") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"y0loScB1") (String:"nSmP4vJF") (((String:"127.0.0.1") (String:"4242")))]) -Sending message as: nSmP4vJF to: y0loScB1 - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"nSmP4vJF") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -ldgv: Network.Socket.connect: : does not exist (Connection refused) -^CTerminated -[laeuferle@workbench ldgvnetworking]$ \ No newline at end of file diff --git a/log/FastNetworkingBug2.log b/log/FastNetworkingBug2.log deleted file mode 100644 index ce672e2..0000000 --- a/log/FastNetworkingBug2.log +++ /dev/null @@ -1,927 +0,0 @@ -29 Handoff4 -subtype: Entering [(c, (0, SendInt))] (Nat) (Int) -subtype: Entering [(x, (0, !Int. ())), (c, (0, SendInt))] (Nat) (Int) -subtype: Entering [ (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (SendOneInt) -subtype: Entering [ (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) -subtype: Entering [ (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz5, (_, Int)) -, (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -subtype: Entering [ (z, (_, ())) -, (n, (_, Int)) -, (x, (_, ())) -, (oneint, (0, SendOneInt)) -, (y, (0, ?SendOneInt. ())) -, (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (z, (_, ())) -, (n, (_, Int)) -, (x, (_, ())) -, (oneint, (0, SendOneInt)) -, (y, (0, ?SendOneInt. ())) -, (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (~SendInt) (~SendInt) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (~SendInt) (?Int. ?Int. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ?Int. ()) (?Int. ?Int. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz6, (_, Int)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) -subtype: Entering [ (zz6, (_, Int)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (zz6, (_, Int)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz7, (_, Int)) -, (zz6, (_, Int)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendSendOneInt) (SendSendOneInt) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendSendOneInt) (!SendOneInt. ?SendOneInt. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (!SendOneInt. ?SendOneInt. ()) (!SendOneInt. ?SendOneInt. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) -subtype: Entering [ (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (SendOneInt) (SendOneInt) -subtype: Entering [ (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (SendOneInt) (?Int. ()) -subtype: Entering [ (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (?Int. ()) (?Int. ()) -subtype: Entering [ (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (Int) (Int) -subtype: [ (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz5, (_, Int)) -, (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (()) (()) -subtype: Entering [(main, (_, ()))] (()) (()) -Trying to connect to: 127.0.0.1:4242 -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (?Int. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz6, (_, Int)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -subtype: [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) = Kssn -subtype: [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (?Int. ()) = Kssn -subtype: [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) = Kssn -subtype: Entering [(c, (0, SendInt))] (Nat) (Int) -subtype: Entering [(x, (0, !Int. ())), (c, (0, SendInt))] (Nat) (Int) -subtype: Entering [ (c3, (_, ())) -, (n, (_, Int)) -, (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (c3, (_, ())) -, (n, (_, Int)) -, (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendInt) (SendInt) -subtype: Entering [ (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendInt) (!Int. !Int. ()) -subtype: Entering [ (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (!Int. !Int. ()) (!Int. !Int. ()) -subtype: Entering [ (zz6, (0, SendOneInt)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (?SendOneInt. ()) (?SendOneInt. ()) -subtype: Entering [ (zz6, (0, SendOneInt)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) -subtype: [ (zz6, (0, SendOneInt)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) = Kssn -subtype: Entering [ (zz7, (0, SendOneInt)) -, (zz6, (0, SendOneInt)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -subtype: Entering [ (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz5, (_, Int)) -, (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (!Int. ()) (!Int. ()) -subtype: Entering [ (zz5, (_, Int)) -, (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (zz5, (_, Int)) -, (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz6, (_, Int)) -, (zz5, (_, Int)) -, (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -subtype: Entering [ (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -Trying to connect to: 127.0.0.1:4242 -Recieved message from unknown connection! - Response to bo2qSbvH: NOkayIntroduce (String:"MgqsgbDo") - Message: NConversationMessage (String:"CYqgTOMK") (NIntroduceClient (String:"bo2qSbvH") (String:"4444") (TName (Bool:False) (String:"SendInt"))) -Sending message as: bo2qSbvH to: MgqsgbDo - Over: 127.0.0.1:4242 - Message: NIntroduceClient (String:"bo2qSbvH") (String:"4444") (TName (Bool:False) (String:"SendInt")) -Sending message as: bo2qSbvH to: MgqsgbDo - Over: 127.0.0.1:4242 - Message: NNewValue (String:"bo2qSbvH") (Int:1) (VInt (Int:1)) -Recieved message as: MgqsgbDo (4242) from: bo2qSbvH - Message: NConversationMessage (String:"ElCjez4i") (NNewValue (String:"bo2qSbvH") (Int:1) (VInt (Int:1))) -Message okay: NNewValue (String:"bo2qSbvH") (Int:1) (VInt (Int:1)) -Sending message as: bo2qSbvH to: MgqsgbDo - Over: 127.0.0.1:4242 - Message: NNewValue (String:"bo2qSbvH") (Int:2) (VInt (Int:42)) -Recieved message as: MgqsgbDo (4242) from: bo2qSbvH - Message: NConversationMessage (String:"qyLarnhF") (NNewValue (String:"bo2qSbvH") (Int:2) (VInt (Int:42))) -Message okay: NNewValue (String:"bo2qSbvH") (Int:2) (VInt (Int:42)) -Recieved Message: NConversationCloseAll -Result: VUnit -Trying to connect to: 127.0.0.1:4242 -Recieved message from unknown connection! - Response to II8HNwke: NOkayIntroduce (String:"4DEOshlP") - Message: NConversationMessage (String:"pfCo4U1v") (NIntroduceClient (String:"II8HNwke") (String:"4343") (TName (Bool:True) (String:"SendSendOneInt"))) -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 -Set RedirectRequest for bo2qSbvH to 127.0.0.1:4343 - Message: NIntroduceClient (String:"II8HNwke") (String:"4343") (TName (Bool:True) (String:"SendSendOneInt")) -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Trying to connect to: 127.0.0.1:4343 -Recieved message as: II8HNwke (4343) from: 4DEOshlP -Sending message as: MgqsgbDo to: bo2qSbvH - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"MgqsgbDo") (String:"4343") -Trying to connect to: 127.0.0.1:4444 -Sending message as: MgqsgbDo to: bo2qSbvH - Over: 127.0.0.1:4444 - Message: NRequestSync (String:"MgqsgbDo") -Error when recieving response -Error when recieving response -Not connected to peer -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Original message: NIntroduceNewPartnerAddress (String:"MgqsgbDo") (String:"4343") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"XSC1nLc3") (NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444"))))) -Trying to connect to: 127.0.0.1:4444 -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Recieved message as: II8HNwke (4343) from: 4DEOshlP -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Error when recieving response -Not connected to peer -Recieved message as: 4DEOshlP (4242) from: II8HNwke -Original message: NRequestSync (String:"MgqsgbDo") -Old communication partner offline! No longer retrying -Set RedirectRequest for bo2qSbvH to 127.0.0.1:4242 -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) - Message: NConversationMessage (String:"EytF478y") (NRequestSync (String:"II8HNwke")) -Recieved message as: 4DEOshlP (4242) from: II8HNwke -Sending message as: MgqsgbDo to: bo2qSbvH - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"MgqsgbDo") (String:"4242") -Trying to connect to: 127.0.0.1:4444 -Message okay: NRequestSync (String:"II8HNwke") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))]) -Sending message as: MgqsgbDo to: bo2qSbvH - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"MgqsgbDo") (String:"4343") -Trying to connect to: 127.0.0.1:4444 -Error when recieving response -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"MgqsgbDo") (String:"4242") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"xQMFBk2S") (NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444"))))) -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"MgqsgbDo") (String:"4343") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"0uWSB08g") (NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Recieved message as: II8HNwke (4343) from: 4DEOshlP -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Recieved message as: 4DEOshlP (4242) from: II8HNwke - Message: NConversationMessage (String:"5KkHQbVf") (NRequestSync (String:"II8HNwke")) -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Recieved message as: 4DEOshlP (4242) from: II8HNwke -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") -Message okay: NRequestSync (String:"II8HNwke") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))]) -Sending message as: MgqsgbDo to: bo2qSbvH - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"MgqsgbDo") (String:"4343") -Trying to connect to: 127.0.0.1:4444 -Error when recieving response -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"MgqsgbDo") (String:"4343") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"BG8Fy8wg") (NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444"))))) -Recieved message as: II8HNwke (4343) from: 4DEOshlP - Message: NConversationMessage (String:"VUSCO9cb") (NRequestSync (String:"4DEOshlP")) -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Recieved message as: II8HNwke (4343) from: 4DEOshlP -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NRequestSync (String:"II8HNwke") -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NRequestSync (String:"II8HNwke") -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NRequestSync (String:"II8HNwke") -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NRequestSync (String:"II8HNwke") -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NRequestSync (String:"II8HNwke") -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NRequestSync (String:"II8HNwke") -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NRequestSync (String:"II8HNwke") -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NRequestSync (String:"II8HNwke") -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NRequestSync (String:"II8HNwke") -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NRequestSync (String:"II8HNwke") -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Sending message as: 4DEOshlP to: II8HNwke -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Error when recieving response -Original message: NRequestSync (String:"II8HNwke") -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NRequestSync (String:"II8HNwke") -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NRequestSync (String:"II8HNwke") -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NRequestSync (String:"II8HNwke") -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NRequestSync (String:"II8HNwke") -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NRequestSync (String:"II8HNwke") -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NRequestSync (String:"II8HNwke") -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NRequestSync (String:"II8HNwke") -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NRequestSync (String:"II8HNwke") -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"II8HNwke") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"4DEOshlP") -Sending message as: 4DEOshlP to: II8HNwke - Over: 127.0.0.1:4343 - Message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Sending message as: II8HNwke to: 4DEOshlP - Over: 127.0.0.1:4242 - Message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NRequestSync (String:"II8HNwke") -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Original message: NRequestSync (String:"4DEOshlP") -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"4DEOshlP") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"II8HNwke") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"bo2qSbvH") (String:"MgqsgbDo") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -^C[laeuferle@workbench ldgvnetworking]$ \ No newline at end of file diff --git a/log/FastNetworkingBug3.log b/log/FastNetworkingBug3.log deleted file mode 100644 index 78969f9..0000000 --- a/log/FastNetworkingBug3.log +++ /dev/null @@ -1,706 +0,0 @@ -3 Handoff4 -subtype: Entering [(c, (0, SendInt))] (Nat) (Int) -subtype: Entering [(x, (0, !Int. ())), (c, (0, SendInt))] (Nat) (Int) -subtype: Entering [ (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (SendOneInt) -subtype: Entering [ (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) -subtype: Entering [ (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (SendOneInt) (SendOneInt) -subtype: Entering [ (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (SendOneInt) (?Int. ()) -subtype: Entering [ (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (?Int. ()) (?Int. ()) -subtype: Entering [ (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (Int) (Int) -subtype: [ (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz5, (_, Int)) -, (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (()) (()) -subtype: Entering [(main, (_, ()))] (()) (()) -Trying to connect to: 127.0.0.1:4242 -subtype: [ (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz5, (_, Int)) -, (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -subtype: Entering [ (z, (_, ())) -, (n, (_, Int)) -, (x, (_, ())) -, (oneint, (0, SendOneInt)) -, (y, (0, ?SendOneInt. ())) -, (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (z, (_, ())) -, (n, (_, Int)) -, (x, (_, ())) -, (oneint, (0, SendOneInt)) -, (y, (0, ?SendOneInt. ())) -, (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (~SendInt) (~SendInt) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (~SendInt) (?Int. ?Int. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ?Int. ()) (?Int. ?Int. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz6, (_, Int)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) -subtype: Entering [ (zz6, (_, Int)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (zz6, (_, Int)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz7, (_, Int)) -, (zz6, (_, Int)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendSendOneInt) (SendSendOneInt) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendSendOneInt) (!SendOneInt. ?SendOneInt. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (!SendOneInt. ?SendOneInt. ()) (!SendOneInt. ?SendOneInt. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (?Int. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz6, (_, Int)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -subtype: [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) = Kssn -subtype: [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (?Int. ()) = Kssn -subtype: [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) = Kssn -subtype: Entering [(c, (0, SendInt))] (Nat) (Int) -subtype: Entering [(x, (0, !Int. ())), (c, (0, SendInt))] (Nat) (Int) -subtype: Entering [ (c3, (_, ())) -, (n, (_, Int)) -, (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (c3, (_, ())) -, (n, (_, Int)) -, (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendInt) (SendInt) -subtype: Entering [ (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendInt) (!Int. !Int. ()) -subtype: Entering [ (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (!Int. !Int. ()) (!Int. !Int. ()) -subtype: Entering [ (zz6, (0, SendOneInt)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (?SendOneInt. ()) (?SendOneInt. ()) -subtype: Entering [ (zz6, (0, SendOneInt)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) -subtype: [ (zz6, (0, SendOneInt)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) = Kssn -subtype: Entering [ (zz7, (0, SendOneInt)) -, (zz6, (0, SendOneInt)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -subtype: Entering [ (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz5, (_, Int)) -, (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (!Int. ()) (!Int. ()) -subtype: Entering [ (zz5, (_, Int)) -, (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (zz5, (_, Int)) -, (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz6, (_, Int)) -, (zz5, (_, Int)) -, (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -subtype: Entering [ (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -Trying to connect to: 127.0.0.1:4242 -Recieved message from unknown connection! - Response to 0ndWisfS: NOkayIntroduce (String:"opqi5Mt5") - Message: NConversationMessage (String:"7JR0O8T1") (NIntroduceClient (String:"0ndWisfS") (String:"4444") (TName (Bool:False) (String:"SendInt"))) -Sending message as: 0ndWisfS to: opqi5Mt5 - Over: 127.0.0.1:4242 - Message: NIntroduceClient (String:"0ndWisfS") (String:"4444") (TName (Bool:False) (String:"SendInt")) -Sending message as: 0ndWisfS to: opqi5Mt5 - Over: 127.0.0.1:4242 - Message: NNewValue (String:"0ndWisfS") (Int:1) (VInt (Int:1)) -Recieved message as: opqi5Mt5 (4242) from: 0ndWisfS - NConversationMessage (String:"HinA5wEN") (NNewValue (String:"0ndWisfS") (Int:1) (VInt (Int:1))) - Message: NConversationMessage (String:"HinA5wEN") (NNewValue (String:"0ndWisfS") (Int:1) (VInt (Int:1))) -Message okay: NNewValue (String:"0ndWisfS") (Int:1) (VInt (Int:1)) -Sending message as: 0ndWisfS to: opqi5Mt5 - Over: 127.0.0.1:4242 - Message: NNewValue (String:"0ndWisfS") (Int:2) (VInt (Int:42)) -Recieved message as: opqi5Mt5 (4242) from: 0ndWisfS - NConversationMessage (String:"e7EWU6Zb") (NNewValue (String:"0ndWisfS") (Int:2) (VInt (Int:42))) - Message: NConversationMessage (String:"e7EWU6Zb") (NNewValue (String:"0ndWisfS") (Int:2) (VInt (Int:42))) -Message okay: NNewValue (String:"0ndWisfS") (Int:2) (VInt (Int:42)) -Recieved Message: NConversationCloseAll -Result: VUnit -Trying to connect to: 127.0.0.1:4242 -Recieved message from unknown connection! - Response to z5qkcWm6: NOkayIntroduce (String:"v7pDHZIA") - Message: NConversationMessage (String:"8KfepN3p") (NIntroduceClient (String:"z5qkcWm6") (String:"4343") (TName (Bool:True) (String:"SendSendOneInt"))) -Set RedirectRequest for 0ndWisfS to 127.0.0.1:4343 -Sending message as: z5qkcWm6 to: v7pDHZIA - Over: 127.0.0.1:4242 -Sending message as: v7pDHZIA to: z5qkcWm6 - Message: NIntroduceClient (String:"z5qkcWm6") (String:"4343") (TName (Bool:True) (String:"SendSendOneInt")) - Over: 127.0.0.1:4343 - Message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Trying to connect to: 127.0.0.1:4343 -Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA - NConversationMessage (String:"mqimYCbH") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: opqi5Mt5 to: 0ndWisfS - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") -Trying to connect to: 127.0.0.1:4444 -Sending message as: opqi5Mt5 to: 0ndWisfS - Over: 127.0.0.1:4444 - Message: NRequestSync (String:"opqi5Mt5") -Error when recieving response -Original message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Not connected to peer -Trying to connect to: 127.0.0.1:4444 -Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"mqimYCbH") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: v7pDHZIA to: z5qkcWm6 - Over: 127.0.0.1:4343 - Message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA - NConversationMessage (String:"b89uRIAt") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: z5qkcWm6 to: v7pDHZIA - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"z5qkcWm6") -Error when recieving response -Not connected to peer -Original message: NRequestSync (String:"opqi5Mt5") -Old communication partner offline! No longer retrying -Set RedirectRequest for 0ndWisfS to 127.0.0.1:4242 -Sending message as: z5qkcWm6 to: v7pDHZIA - Over: 127.0.0.1:4242 - Message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 - NConversationMessage (String:"VgenmU3j") (NRequestSync (String:"z5qkcWm6")) - Message: NConversationMessage (String:"VgenmU3j") (NRequestSync (String:"z5qkcWm6")) -Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 - NConversationMessage (String:"wDvD3Uey") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: opqi5Mt5 to: 0ndWisfS - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") -Trying to connect to: 127.0.0.1:4444 -Message okay: NRequestSync (String:"z5qkcWm6") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) -Sending message as: opqi5Mt5 to: 0ndWisfS - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") -Trying to connect to: 127.0.0.1:4444 -Error when recieving response -Original message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Original message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"wDvD3Uey") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"b89uRIAt") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: v7pDHZIA to: z5qkcWm6 - Over: 127.0.0.1:4343 - Message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA - NConversationMessage (String:"gkALmpIw") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: z5qkcWm6 to: v7pDHZIA - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"z5qkcWm6") -Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 - NConversationMessage (String:"rtEunpy5") (NRequestSync (String:"z5qkcWm6")) - Message: NConversationMessage (String:"rtEunpy5") (NRequestSync (String:"z5qkcWm6")) -Message okay: NRequestSync (String:"z5qkcWm6") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) -Sending message as: opqi5Mt5 to: 0ndWisfS - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") -Trying to connect to: 127.0.0.1:4444 -Sending message as: z5qkcWm6 to: v7pDHZIA - Over: 127.0.0.1:4242 - Message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"gkALmpIw") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 - NConversationMessage (String:"OShDQea8") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: v7pDHZIA to: z5qkcWm6 - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"v7pDHZIA") -Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA - NConversationMessage (String:"EOBR51VZ") (NRequestSync (String:"v7pDHZIA")) - Message: NConversationMessage (String:"EOBR51VZ") (NRequestSync (String:"v7pDHZIA")) -Message okay: NRequestSync (String:"v7pDHZIA") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) -Sending message as: opqi5Mt5 to: 0ndWisfS - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") -Trying to connect to: 127.0.0.1:4444 -Sending message as: v7pDHZIA to: z5qkcWm6 - Over: 127.0.0.1:4343 - Message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"OShDQea8") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA - NConversationMessage (String:"czKQA1XT") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: z5qkcWm6 to: v7pDHZIA - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"z5qkcWm6") -Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 - NConversationMessage (String:"VQX9jXAK") (NRequestSync (String:"z5qkcWm6")) - Message: NConversationMessage (String:"VQX9jXAK") (NRequestSync (String:"z5qkcWm6")) -Message okay: NRequestSync (String:"z5qkcWm6") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) -Sending message as: opqi5Mt5 to: 0ndWisfS - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") -Trying to connect to: 127.0.0.1:4444 -Sending message as: z5qkcWm6 to: v7pDHZIA - Over: 127.0.0.1:4242 - Message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"czKQA1XT") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 - NConversationMessage (String:"9gBvfDO3") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: v7pDHZIA to: z5qkcWm6 - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"v7pDHZIA") -Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA - NConversationMessage (String:"BbHUwwOB") (NRequestSync (String:"v7pDHZIA")) - Message: NConversationMessage (String:"BbHUwwOB") (NRequestSync (String:"v7pDHZIA")) -Message okay: NRequestSync (String:"v7pDHZIA") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) -Sending message as: opqi5Mt5 to: 0ndWisfS - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") -Trying to connect to: 127.0.0.1:4444 -Sending message as: v7pDHZIA to: z5qkcWm6 - Over: 127.0.0.1:4343 - Message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"9gBvfDO3") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA - NConversationMessage (String:"eB6tYctB") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: z5qkcWm6 to: v7pDHZIA - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"z5qkcWm6") -Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 - NConversationMessage (String:"z0fwWWLw") (NRequestSync (String:"z5qkcWm6")) - Message: NConversationMessage (String:"z0fwWWLw") (NRequestSync (String:"z5qkcWm6")) -Message okay: NRequestSync (String:"z5qkcWm6") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) -Sending message as: opqi5Mt5 to: 0ndWisfS - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") -Trying to connect to: 127.0.0.1:4444 -Sending message as: z5qkcWm6 to: v7pDHZIA - Over: 127.0.0.1:4242 - Message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"eB6tYctB") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 - NConversationMessage (String:"MEoNrJ5w") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: v7pDHZIA to: z5qkcWm6 - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"v7pDHZIA") -Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA - NConversationMessage (String:"efVlRDkm") (NRequestSync (String:"v7pDHZIA")) - Message: NConversationMessage (String:"efVlRDkm") (NRequestSync (String:"v7pDHZIA")) -Message okay: NRequestSync (String:"v7pDHZIA") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) -Sending message as: opqi5Mt5 to: 0ndWisfS - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") -Trying to connect to: 127.0.0.1:4444 -Sending message as: v7pDHZIA to: z5qkcWm6 - Over: 127.0.0.1:4343 - Message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"MEoNrJ5w") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA - NConversationMessage (String:"KVxqzA0Z") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: z5qkcWm6 to: v7pDHZIA - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"z5qkcWm6") -Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 - NConversationMessage (String:"7xupNmIX") (NRequestSync (String:"z5qkcWm6")) - Message: NConversationMessage (String:"7xupNmIX") (NRequestSync (String:"z5qkcWm6")) -Message okay: NRequestSync (String:"z5qkcWm6") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) -Sending message as: opqi5Mt5 to: 0ndWisfS - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") -Trying to connect to: 127.0.0.1:4444 -Sending message as: z5qkcWm6 to: v7pDHZIA - Over: 127.0.0.1:4242 - Message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"KVxqzA0Z") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 - NConversationMessage (String:"Eu2mzaCi") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: v7pDHZIA to: z5qkcWm6 - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"v7pDHZIA") -Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA - NConversationMessage (String:"iFmAfU9I") (NRequestSync (String:"v7pDHZIA")) - Message: NConversationMessage (String:"iFmAfU9I") (NRequestSync (String:"v7pDHZIA")) -Message okay: NRequestSync (String:"v7pDHZIA") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) -Sending message as: opqi5Mt5 to: 0ndWisfS - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") -Trying to connect to: 127.0.0.1:4444 -Sending message as: v7pDHZIA to: z5qkcWm6 - Over: 127.0.0.1:4343 - Message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"Eu2mzaCi") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA - NConversationMessage (String:"EHFOtFgj") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: z5qkcWm6 to: v7pDHZIA - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"z5qkcWm6") -Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 - NConversationMessage (String:"0FnB0n6H") (NRequestSync (String:"z5qkcWm6")) - Message: NConversationMessage (String:"0FnB0n6H") (NRequestSync (String:"z5qkcWm6")) -Message okay: NRequestSync (String:"z5qkcWm6") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) -Sending message as: opqi5Mt5 to: 0ndWisfS - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") -Trying to connect to: 127.0.0.1:4444 -Sending message as: z5qkcWm6 to: v7pDHZIA - Over: 127.0.0.1:4242 - Message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"EHFOtFgj") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 - NConversationMessage (String:"DOFILdDN") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: v7pDHZIA to: z5qkcWm6 - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"v7pDHZIA") -Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA - NConversationMessage (String:"PSCyb6f9") (NRequestSync (String:"v7pDHZIA")) - Message: NConversationMessage (String:"PSCyb6f9") (NRequestSync (String:"v7pDHZIA")) -Message okay: NRequestSync (String:"v7pDHZIA") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) -Sending message as: opqi5Mt5 to: 0ndWisfS - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") -Trying to connect to: 127.0.0.1:4444 -Sending message as: v7pDHZIA to: z5qkcWm6 - Over: 127.0.0.1:4343 - Message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4242 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"DOFILdDN") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA - NConversationMessage (String:"59Jae5tu") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: z5qkcWm6 to: v7pDHZIA - Over: 127.0.0.1:4242 - Message: NRequestSync (String:"z5qkcWm6") -Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 - NConversationMessage (String:"UhrVmx7p") (NRequestSync (String:"z5qkcWm6")) - Message: NConversationMessage (String:"UhrVmx7p") (NRequestSync (String:"z5qkcWm6")) -Message okay: NRequestSync (String:"z5qkcWm6") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) -Sending message as: opqi5Mt5 to: 0ndWisfS - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") -Trying to connect to: 127.0.0.1:4444 -Sending message as: z5qkcWm6 to: v7pDHZIA - Over: 127.0.0.1:4242 - Message: NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Original message: NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))) -Old communication partner offline! New communication partner: 127.0.0.1:4343 -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4343") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"59Jae5tu") (NNewValue (String:"v7pDHZIA") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Recieved message as: v7pDHZIA (4242) from: z5qkcWm6 - NConversationMessage (String:"NsKpbM2L") (NNewValue (String:"z5qkcWm6") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: v7pDHZIA to: z5qkcWm6 - Over: 127.0.0.1:4343 - Message: NRequestSync (String:"v7pDHZIA") -Recieved message as: z5qkcWm6 (4343) from: v7pDHZIA - NConversationMessage (String:"BRVOj93u") (NRequestSync (String:"v7pDHZIA")) - Message: NConversationMessage (String:"BRVOj93u") (NRequestSync (String:"v7pDHZIA")) -Message okay: NRequestSync (String:"v7pDHZIA") -Got syncronization values: NOkaySync (SValuesArray [VChanSerial (((SValuesArray [VInt (Int:1), VInt (Int:42)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"0ndWisfS") (String:"opqi5Mt5") (((String:"127.0.0.1") (String:"4444")))]) -Sending message as: opqi5Mt5 to: 0ndWisfS - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"opqi5Mt5") (String:"4242") -Trying to connect to: 127.0.0.1:4444 -^C[laeuferle@workbench ldgvnetworking]$ \ No newline at end of file diff --git a/log/FastNetworkingBug4.log b/log/FastNetworkingBug4.log deleted file mode 100644 index 70989fe..0000000 --- a/log/FastNetworkingBug4.log +++ /dev/null @@ -1,386 +0,0 @@ -68 Handoff4 -subtype: Entering [(c, (0, SendInt))] (Nat) (Int) -subtype: Entering [(x, (0, !Int. ())), (c, (0, SendInt))] (Nat) (Int) -subtype: Entering [ (c3, (_, ())) -, (n, (_, Int)) -, (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (c3, (_, ())) -, (n, (_, Int)) -, (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendInt) (SendInt) -subtype: Entering [ (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendInt) (!Int. !Int. ()) -subtype: Entering [ (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (!Int. !Int. ()) (!Int. !Int. ()) -subtype: Entering [ (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz5, (_, Int)) -, (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (!Int. ()) (!Int. ()) -subtype: Entering [ (zz5, (_, Int)) -, (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (zz5, (_, Int)) -, (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz6, (_, Int)) -, (zz5, (_, Int)) -, (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -subtype: Entering [ (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -Trying to connect to: 127.0.0.1:4242 -subtype: Entering [(c, (0, SendInt))] (Nat) (Int) -subtype: Entering [(x, (0, !Int. ())), (c, (0, SendInt))] (Nat) (Int) -subtype: Entering [ (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (SendOneInt) -subtype: Entering [ (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) -subtype: Entering [ (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (SendOneInt) (SendOneInt) -subtype: Entering [ (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (SendOneInt) (?Int. ()) -subtype: Entering [ (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (?Int. ()) (?Int. ()) -subtype: Entering [ (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (Int) (Int) -subtype: [ (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz5, (_, Int)) -, (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (()) (()) -subtype: Entering [(main, (_, ()))] (()) (()) -Trying to connect to: 127.0.0.1:4242 -subtype: [ (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz5, (_, Int)) -, (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -subtype: Entering [ (z, (_, ())) -, (n, (_, Int)) -, (x, (_, ())) -, (oneint, (0, SendOneInt)) -, (y, (0, ?SendOneInt. ())) -, (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (z, (_, ())) -, (n, (_, Int)) -, (x, (_, ())) -, (oneint, (0, SendOneInt)) -, (y, (0, ?SendOneInt. ())) -, (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (~SendInt) (~SendInt) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (~SendInt) (?Int. ?Int. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ?Int. ()) (?Int. ?Int. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz6, (_, Int)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) -subtype: Entering [ (zz6, (_, Int)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (zz6, (_, Int)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz7, (_, Int)) -, (zz6, (_, Int)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendSendOneInt) (SendSendOneInt) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendSendOneInt) (!SendOneInt. ?SendOneInt. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (!SendOneInt. ?SendOneInt. ()) (!SendOneInt. ?SendOneInt. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (?Int. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz6, (_, Int)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -subtype: [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) = Kssn -subtype: [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (?Int. ()) = Kssn -subtype: [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) = Kssn -subtype: Entering [ (zz6, (0, SendOneInt)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (?SendOneInt. ()) (?SendOneInt. ()) -subtype: Entering [ (zz6, (0, SendOneInt)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) -subtype: [ (zz6, (0, SendOneInt)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) = Kssn -subtype: Entering [ (zz7, (0, SendOneInt)) -, (zz6, (0, SendOneInt)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -subtype: Entering [ (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -Trying to connect to: 127.0.0.1:4242 -Recieved message from unknown connection! - Response to VpPec4uW: NOkayIntroduce (String:"jH1858Qj") - Message: NConversationMessage (String:"S3CtxIOM") (NIntroduceClient (String:"VpPec4uW") (String:"4444") (TName (Bool:False) (String:"SendInt"))) -Sending message as: VpPec4uW to: jH1858Qj - Over: 127.0.0.1:4242 - Message: NIntroduceClient (String:"VpPec4uW") (String:"4444") (TName (Bool:False) (String:"SendInt")) -Sending message as: VpPec4uW to: jH1858Qj - Over: 127.0.0.1:4242 - Message: NNewValue (String:"VpPec4uW") (Int:1) (VInt (Int:1)) -Trying to connect to: 127.0.0.1:4242 -Recieved message as: jH1858Qj (4242) from: VpPec4uW - NConversationMessage (String:"4TMypj1q") (NNewValue (String:"VpPec4uW") (Int:1) (VInt (Int:1))) - Message: NConversationMessage (String:"4TMypj1q") (NNewValue (String:"VpPec4uW") (Int:1) (VInt (Int:1))) -Recieved message from unknown connection! - Response to vMZnsPjr: NOkayIntroduce (String:"UlCVAW3h") - Message: NConversationMessage (String:"BgozYUq4") (NIntroduceClient (String:"vMZnsPjr") (String:"4343") (TName (Bool:True) (String:"SendSendOneInt"))) -Message okay: NNewValue (String:"VpPec4uW") (Int:1) (VInt (Int:1)) -Sending message as: VpPec4uW to: jH1858Qj - Over: 127.0.0.1:4242 - Message: NNewValue (String:"VpPec4uW") (Int:2) (VInt (Int:42)) -Recieved message as: jH1858Qj (4242) from: VpPec4uW -Set RedirectRequest for VpPec4uW to 127.0.0.1:4343 - NConversationMessage (String:"BCDcGrTr") (NNewValue (String:"VpPec4uW") (Int:2) (VInt (Int:42))) -Sending message as: UlCVAW3h to: vMZnsPjr - Over: 127.0.0.1:4343 - Message: NConversationMessage (String:"BCDcGrTr") (NNewValue (String:"VpPec4uW") (Int:2) (VInt (Int:42))) - Message: NNewValue (String:"UlCVAW3h") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"VpPec4uW") (String:"jH1858Qj") (((String:"127.0.0.1") (String:"4444")))) -Trying to connect to: 127.0.0.1:4343 -Sending message as: vMZnsPjr to: UlCVAW3h - Over: 127.0.0.1:4242 - Message: NIntroduceClient (String:"vMZnsPjr") (String:"4343") (TName (Bool:True) (String:"SendSendOneInt")) -Message okay: NNewValue (String:"VpPec4uW") (Int:2) (VInt (Int:42)) -Recieved Message: NConversationCloseAll -Recieved message as: vMZnsPjr (4343) from: UlCVAW3h - NConversationMessage (String:"63Rah82u") (NNewValue (String:"UlCVAW3h") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"VpPec4uW") (String:"jH1858Qj") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: jH1858Qj to: VpPec4uW - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"jH1858Qj") (String:"4343") -Trying to connect to: 127.0.0.1:4444 -Result: VUnit -Sending message as: jH1858Qj to: VpPec4uW - Over: 127.0.0.1:4444 - Message: NRequestSync (String:"jH1858Qj") -Set RedirectRequest for VpPec4uW to 127.0.0.1:4242 -Sending message as: vMZnsPjr to: UlCVAW3h - Over: 127.0.0.1:4242 - Message: NConversationMessage (String:"63Rah82u") (NNewValue (String:"UlCVAW3h") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"VpPec4uW") (String:"jH1858Qj") (((String:"127.0.0.1") (String:"4444"))))) - Message: NNewValue (String:"vMZnsPjr") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"VpPec4uW") (String:"jH1858Qj") (((String:"127.0.0.1") (String:"4444")))) -Recieved message as: UlCVAW3h (4242) from: vMZnsPjr - NConversationMessage (String:"OVTL5vVl") (NNewValue (String:"vMZnsPjr") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"VpPec4uW") (String:"jH1858Qj") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: jH1858Qj to: VpPec4uW - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"jH1858Qj") (String:"4242") -Trying to connect to: 127.0.0.1:4444 -Message okay: NNewValue (String:"UlCVAW3h") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"VpPec4uW") (String:"jH1858Qj") (((String:"127.0.0.1") (String:"4444")))) -Error when recieving response -Not connected to peer -Original message: NIntroduceNewPartnerAddress (String:"jH1858Qj") (String:"4242") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"OVTL5vVl") (NNewValue (String:"vMZnsPjr") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"VpPec4uW") (String:"jH1858Qj") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: jH1858Qj to: VpPec4uW - Over: 127.0.0.1:4444 - Message: NRequestSync (String:"jH1858Qj") -Trying to connect to: 127.0.0.1:4444 -Message okay: NNewValue (String:"vMZnsPjr") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"VpPec4uW") (String:"jH1858Qj") (((String:"127.0.0.1") (String:"4444")))) -Recieved Message: NConversationCloseAll -Error: : commitBuffer: resource vanished (Broken pipe) -Error when recieving response -Not connected to peer -Original message: NRequestSync (String:"jH1858Qj") -Old communication partner offline! No longer retrying \ No newline at end of file diff --git a/log/FastNetworkingBug5.log b/log/FastNetworkingBug5.log deleted file mode 100644 index 7783cef..0000000 --- a/log/FastNetworkingBug5.log +++ /dev/null @@ -1,386 +0,0 @@ -635 Handoff4 -subtype: Entering [(c, (0, SendInt))] (Nat) (Int) -subtype: Entering [(x, (0, !Int. ())), (c, (0, SendInt))] (Nat) (Int) -subtype: Entering [ (c3, (_, ())) -, (n, (_, Int)) -, (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (c3, (_, ())) -, (n, (_, Int)) -, (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendInt) (SendInt) -subtype: Entering [ (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendInt) (!Int. !Int. ()) -subtype: Entering [ (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (!Int. !Int. ()) (!Int. !Int. ()) -subtype: Entering [ (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz5, (_, Int)) -, (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (!Int. ()) (!Int. ()) -subtype: Entering [ (zz5, (_, Int)) -, (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (zz5, (_, Int)) -, (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz6, (_, Int)) -, (zz5, (_, Int)) -, (con, (0, SendInt)) -, (sock, (_, Nat)) -, (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -subtype: Entering [ (main, (_, ())) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -Trying to connect to: 127.0.0.1:4242 -subtype: Entering [(c, (0, SendInt))] (Nat) (Int) -subtype: Entering [(x, (0, !Int. ())), (c, (0, SendInt))] (Nat) (Int) -subtype: Entering [ (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (SendOneInt) -subtype: Entering [ (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) -subtype: Entering [ (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (SendOneInt) (SendOneInt) -subtype: Entering [ (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (SendOneInt) (?Int. ()) -subtype: Entering [ (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (?Int. ()) (?Int. ()) -subtype: Entering [ (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (Int) (Int) -subtype: [ (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz5, (_, Int)) -, (c2, (0, !SendOneInt. ())) -, (oneint, (0, SendOneInt)) -, (con, (0, ~SendSendOneInt)) -, (sock, (_, Nat)) -, (main, (_, ())) ] (()) (()) -subtype: Entering [(main, (_, ()))] (()) (()) -Trying to connect to: 127.0.0.1:4242 -subtype: [ (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz5, (_, Int)) -, (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -subtype: Entering [ (z, (_, ())) -, (n, (_, Int)) -, (x, (_, ())) -, (oneint, (0, SendOneInt)) -, (y, (0, ?SendOneInt. ())) -, (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (z, (_, ())) -, (n, (_, Int)) -, (x, (_, ())) -, (oneint, (0, SendOneInt)) -, (y, (0, ?SendOneInt. ())) -, (c2, (0, ?Int. ())) -, (m, (_, Int)) -, (c3, (0, SendSendOneInt)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (~SendInt) (~SendInt) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (~SendInt) (?Int. ?Int. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ?Int. ()) (?Int. ?Int. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz6, (_, Int)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) -subtype: Entering [ (zz6, (_, Int)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (zz6, (_, Int)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz7, (_, Int)) -, (zz6, (_, Int)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendSendOneInt) (SendSendOneInt) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendSendOneInt) (!SendOneInt. ?SendOneInt. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (!SendOneInt. ?SendOneInt. ()) (!SendOneInt. ?SendOneInt. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (?Int. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) -subtype: Entering [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -subtype: [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) = Kunit -subtype: Entering [ (zz6, (_, Int)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -subtype: [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (?Int. ()) (?Int. ()) = Kssn -subtype: [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (?Int. ()) = Kssn -subtype: [ (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) = Kssn -subtype: Entering [ (zz6, (0, SendOneInt)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (?SendOneInt. ()) (?SendOneInt. ()) -subtype: Entering [ (zz6, (0, SendOneInt)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) -subtype: [ (zz6, (0, SendOneInt)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (SendOneInt) (SendOneInt) = Kssn -subtype: Entering [ (zz7, (0, SendOneInt)) -, (zz6, (0, SendOneInt)) -, (con2, (0, SendSendOneInt)) -, (con1, (0, ~SendInt)) -, (sock, (_, Nat)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (()) (()) -subtype: Entering [ (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> (c3 : SendSendOneInt) -> Int)) -, (send2, (_, (c : SendInt) -> ())) ] (Int) (Int) -Trying to connect to: 127.0.0.1:4242 -Recieved message from unknown connection! - Response to 2qtKSkk0: NOkayIntroduce (String:"jeXkisal") - Message: NConversationMessage (String:"zX5GFXLS") (NIntroduceClient (String:"2qtKSkk0") (String:"4444") (TName (Bool:False) (String:"SendInt"))) -Trying to connect to: 127.0.0.1:4242 -Sending message as: 2qtKSkk0 to: jeXkisal - Over: 127.0.0.1:4242 - Message: NIntroduceClient (String:"2qtKSkk0") (String:"4444") (TName (Bool:False) (String:"SendInt")) -Sending message as: 2qtKSkk0 to: jeXkisal - Over: 127.0.0.1:4242 - Message: NNewValue (String:"2qtKSkk0") (Int:1) (VInt (Int:1)) -Recieved message as: jeXkisal (4242) from: 2qtKSkk0 - NConversationMessage (String:"TnqJUqNq") (NNewValue (String:"2qtKSkk0") (Int:1) (VInt (Int:1))) - Message: NConversationMessage (String:"TnqJUqNq") (NNewValue (String:"2qtKSkk0") (Int:1) (VInt (Int:1))) -Recieved message from unknown connection! - Response to wmx6A5ja: NOkayIntroduce (String:"ZiF6PJBB") - Message: NConversationMessage (String:"VfQAXOMt") (NIntroduceClient (String:"wmx6A5ja") (String:"4343") (TName (Bool:True) (String:"SendSendOneInt"))) -Message okay: NNewValue (String:"2qtKSkk0") (Int:1) (VInt (Int:1)) -Sending message as: 2qtKSkk0 to: jeXkisal - Over: 127.0.0.1:4242 - Message: NNewValue (String:"2qtKSkk0") (Int:2) (VInt (Int:42)) -Recieved message as: jeXkisal (4242) from: 2qtKSkk0 -Set RedirectRequest for 2qtKSkk0 to 127.0.0.1:4343 - NConversationMessage (String:"WTBsV5Na") (NNewValue (String:"2qtKSkk0") (Int:2) (VInt (Int:42))) - Message: NConversationMessage (String:"WTBsV5Na") (NNewValue (String:"2qtKSkk0") (Int:2) (VInt (Int:42))) -Sending message as: ZiF6PJBB to: wmx6A5ja - Over: 127.0.0.1:4343 - Message: NNewValue (String:"ZiF6PJBB") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"2qtKSkk0") (String:"jeXkisal") (((String:"127.0.0.1") (String:"4444")))) -Trying to connect to: 127.0.0.1:4343 -Sending message as: wmx6A5ja to: ZiF6PJBB - Over: 127.0.0.1:4242 - Message: NIntroduceClient (String:"wmx6A5ja") (String:"4343") (TName (Bool:True) (String:"SendSendOneInt")) -Message okay: NNewValue (String:"2qtKSkk0") (Int:2) (VInt (Int:42)) -Recieved Message: NConversationCloseAll -Recieved message as: wmx6A5ja (4343) from: ZiF6PJBB - NConversationMessage (String:"LavJod41") (NNewValue (String:"ZiF6PJBB") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"2qtKSkk0") (String:"jeXkisal") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: jeXkisal to: 2qtKSkk0 -Result: VUnit - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"jeXkisal") (String:"4343") -Trying to connect to: 127.0.0.1:4444 -Sending message as: jeXkisal to: 2qtKSkk0 - Over: 127.0.0.1:4444 - Message: NRequestSync (String:"jeXkisal") -Set RedirectRequest for 2qtKSkk0 to 127.0.0.1:4242 -Sending message as: wmx6A5ja to: ZiF6PJBB - Message: NConversationMessage (String:"LavJod41") (NNewValue (String:"ZiF6PJBB") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"2qtKSkk0") (String:"jeXkisal") (((String:"127.0.0.1") (String:"4444"))))) - Over: 127.0.0.1:4242 - Message: NNewValue (String:"wmx6A5ja") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"2qtKSkk0") (String:"jeXkisal") (((String:"127.0.0.1") (String:"4444")))) -Message okay: NNewValue (String:"ZiF6PJBB") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"2qtKSkk0") (String:"jeXkisal") (((String:"127.0.0.1") (String:"4444")))) -Recieved message as: ZiF6PJBB (4242) from: wmx6A5ja - NConversationMessage (String:"Fn1geJ94") (NNewValue (String:"wmx6A5ja") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"2qtKSkk0") (String:"jeXkisal") (((String:"127.0.0.1") (String:"4444"))))) -Sending message as: jeXkisal to: 2qtKSkk0 - Over: 127.0.0.1:4444 - Message: NIntroduceNewPartnerAddress (String:"jeXkisal") (String:"4242") -Trying to connect to: 127.0.0.1:4444 -Sending message as: jeXkisal to: 2qtKSkk0 - Over: 127.0.0.1:4444 - Message: NRequestSync (String:"jeXkisal") -Error when recieving response -Not connected to peer -Trying to connect to: 127.0.0.1:4444 -Original message: NIntroduceNewPartnerAddress (String:"jeXkisal") (String:"4242") -Old communication partner offline! No longer retrying - Message: NConversationMessage (String:"Fn1geJ94") (NNewValue (String:"wmx6A5ja") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"2qtKSkk0") (String:"jeXkisal") (((String:"127.0.0.1") (String:"4444"))))) -Message okay: NNewValue (String:"wmx6A5ja") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray []) (Int:0))) (String:"2qtKSkk0") (String:"jeXkisal") (((String:"127.0.0.1") (String:"4444")))) -Recieved Message: NConversationCloseAll -Error: : commitBuffer: resource vanished (Broken pipe) -Error when recieving response -Not connected to peer -Original message: NRequestSync (String:"jeXkisal") -Old communication partner offline! No longer retrying diff --git a/log/FastNetworkingBug6.log b/log/FastNetworkingBug6.log deleted file mode 100644 index 2b92335..0000000 --- a/log/FastNetworkingBug6.log +++ /dev/null @@ -1,568 +0,0 @@ -2 Bidirhandoff -subtype: Entering [(c, (0, SendInt))] (Nat) (Int) -subtype: Entering [ (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Nat) (Int) -subtype: Entering [ (y2, (_, ())) -, (m, (_, Int)) -, (y, (0, ?Int. ())) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Int) (Int) -subtype: Entering [(c, (0, SendInt))] (Nat) (Int) -subtype: Entering [ (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Nat) (Int) -subtype: Entering [ (y2, (_, ())) -, (m, (_, Int)) -, (y, (0, ?Int. ())) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Int) (Int) -subtype: Entering [ (y2, (_, ())) -, (m, (_, Int)) -, (y, (0, ?Int. ())) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Int) (Int) -subtype: Entering [ (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (c32, (_, ())) -, (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: Entering [ (c32, (_, ())) -, (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: Entering [ (c2, (0, !Int. ())) -, (m, (_, Int)) -, (c1, (_, ())) -, (talk, (0, SendIntServer)) -, (con, (0, ~SendSendIntServer)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -Trying to connect to: 127.0.0.1:4242 -subtype: Entering [(c, (0, SendInt))] (Nat) (Int) -subtype: Entering [ (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Nat) (Int) -subtype: Entering [ (y2, (_, ())) -, (m, (_, Int)) -, (y, (0, ?Int. ())) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Int) (Int) -subtype: Entering [(c, (0, SendInt))] (Nat) (Int) -subtype: Entering [ (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Nat) (Int) -subtype: Entering [ (y2, (_, ())) -, (m, (_, Int)) -, (y, (0, ?Int. ())) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Int) (Int) -subtype: Entering [ (y2, (_, ())) -, (m, (_, Int)) -, (y, (0, ?Int. ())) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Int) (Int) -subtype: Entering [ (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (c32, (_, ())) -, (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: Entering [ (c32, (_, ())) -, (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: Entering [ (y, (_, ())) -, (talk, (0, SendIntClient)) -, (con, (0, ~SendSendIntClient)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: Entering [ (y2, (_, ())) -, (m, (_, Int)) -, (y, (0, ?Int. ())) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Int) (Int) -subtype: Entering [ (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (c32, (_, ())) -, (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: Entering [ (c32, (_, ())) -, (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: Entering [ (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (con, (0, ~SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (con2, (0, SendSendIntServer)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (con, (0, ~SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (?Int. !Int. ()) (SendIntServer) -subtype: Entering [ (con2, (0, SendSendIntServer)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (con, (0, ~SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (?Int. !Int. ()) (?Int. !Int. ()) -subtype: Entering [ (y2, (_, ())) -, (m, (_, Int)) -, (y, (0, ?Int. ())) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (c, (0, SendInt)) ] (Int) (Int) -subtype: Entering [ (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (c32, (_, ())) -, (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: Entering [ (c32, (_, ())) -, (c3, (0, !Int. ())) -, (n, (_, Int)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (c1, (0, ~SendInt)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: Entering [ (con, (0, SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Nat) (Int) -subtype: Entering [ (con2, (0, SendSendIntClient)) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (con, (0, SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (!Int. ?Int. ()) (SendIntClient) -subtype: Entering [ (con2, (0, SendSendIntClient)) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (con, (0, SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (!Int. ?Int. ()) (!Int. ?Int. ()) -subtype: Entering [ (con2, (0, SendSendIntServer)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (con, (0, ~SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: [ (con2, (0, SendSendIntServer)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (con, (0, ~SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) = Kunit -subtype: Entering [ (zz8, (_, Int)) -, (con2, (0, SendSendIntServer)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (con, (0, ~SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (!Int. ()) (!Int. ()) -subtype: Entering [ (zz8, (_, Int)) -, (con2, (0, SendSendIntServer)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (con, (0, ~SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: [ (zz8, (_, Int)) -, (con2, (0, SendSendIntServer)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (con, (0, ~SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) = Kunit -subtype: Entering [ (zz9, (_, Int)) -, (zz8, (_, Int)) -, (con2, (0, SendSendIntServer)) -, (c22, (0, ?Int. !Int. ())) -, (c2, (0, !Int. ?Int. !Int. ())) -, (m, (_, Int)) -, (con, (0, ~SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (()) (()) -subtype: Entering [ (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: Entering [ (con2, (0, SendSendIntClient)) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (con, (0, SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: [ (con2, (0, SendSendIntClient)) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (con, (0, SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) = Kunit -subtype: Entering [ (zz8, (_, Int)) -, (con2, (0, SendSendIntClient)) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (con, (0, SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (?Int. ()) (?Int. ()) -subtype: Entering [ (zz8, (_, Int)) -, (con2, (0, SendSendIntClient)) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (con, (0, SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -subtype: [ (zz8, (_, Int)) -, (con2, (0, SendSendIntClient)) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (con, (0, SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) = Kunit -subtype: Entering [ (zz9, (_, Int)) -, (zz8, (_, Int)) -, (con2, (0, SendSendIntClient)) -, (x2, (0, !Int. ?Int. ())) -, (n, (_, Int)) -, (x, (0, ?Int. !Int. ?Int. ())) -, (con, (0, SendInt)) -, (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (()) (()) -subtype: Entering [ (main, (_, Int)) -, (add2, (_, (c1 : ~SendInt) -> Int)) -, (send2, (_, (c : SendInt) -> Int)) ] (Int) (Int) -Trying to connect to: 127.0.0.1:4242 -Recieved message from unknown connection! - Response to 7rgEnvHL: NOkayIntroduce (String:"nISByehk") - Message: NConversationMessage (String:"shD3v8xj") (NIntroduceClient (String:"7rgEnvHL") (String:"4343") (TName (Bool:False) (String:"SendInt")) (TSend (String:"#!") (TInt) (TRecv (String:"#?") (TInt) (TSend (String:"#!") (TInt) (TRecv (String:"#?") (TInt) (TUnit)))))) -Sending message as: 7rgEnvHL to: nISByehk - Over: 127.0.0.1:4242 -Trying to connect to: 127.0.0.1:4242 - Message: NIntroduceClient (String:"7rgEnvHL") (String:"4343") (TName (Bool:False) (String:"SendInt")) (TSend (String:"#!") (TInt) (TRecv (String:"#?") (TInt) (TSend (String:"#!") (TInt) (TRecv (String:"#?") (TInt) (TUnit))))) -Sending message as: 7rgEnvHL to: nISByehk - Over: 127.0.0.1:4242 - Message: NNewValue (String:"7rgEnvHL") (Int:1) (VInt (Int:1)) -Recieved message from unknown connection! - Response to 4MHbSLnZ: NOkayIntroduce (String:"qZXgVJiD") - Message: NConversationMessage (String:"yCLqfaI7") (NIntroduceClient (String:"4MHbSLnZ") (String:"4240") (TName (Bool:True) (String:"SendSendIntServer")) (TSend (String:"#!") (TName (Bool:False) (String:"SendIntServer")) (TUnit))) -Recieved message as: nISByehk (4242) from: 7rgEnvHL - NConversationMessage (String:"KPyBCp2x") (NNewValue (String:"7rgEnvHL") (Int:1) (VInt (Int:1))) - Message: NConversationMessage (String:"KPyBCp2x") (NNewValue (String:"7rgEnvHL") (Int:1) (VInt (Int:1))) -Sending message as: nISByehk to: 7rgEnvHL - Over: 127.0.0.1:4343 - Message: NNewValue (String:"nISByehk") (Int:1) (VInt (Int:1300)) -Trying to connect to: 127.0.0.1:4343 -Sending message as: 4MHbSLnZ to: qZXgVJiD - Over: 127.0.0.1:4242 - Message: NIntroduceClient (String:"4MHbSLnZ") (String:"4240") (TName (Bool:True) (String:"SendSendIntServer")) (TSend (String:"#!") (TName (Bool:False) (String:"SendIntServer")) (TUnit)) -Message okay: NNewValue (String:"7rgEnvHL") (Int:1) (VInt (Int:1)) -Recieved message as: 7rgEnvHL (4343) from: nISByehk - NConversationMessage (String:"9dblOYp2") (NNewValue (String:"nISByehk") (Int:1) (VInt (Int:1300))) - Message: NConversationMessage (String:"9dblOYp2") (NNewValue (String:"nISByehk") (Int:1) (VInt (Int:1300))) -Trying to connect to: 127.0.0.1:4340 -Recieved message from unknown connection! - Response to 7tTIigo7: NOkayIntroduce (String:"MiquZROF") - Message: NConversationMessage (String:"jVHOkaFZ") (NIntroduceClient (String:"7tTIigo7") (String:"4343") (TName (Bool:False) (String:"SendSendIntClient")) (TSend (String:"#!") (TName (Bool:False) (String:"SendIntClient")) (TUnit))) -Message okay: NNewValue (String:"nISByehk") (Int:1) (VInt (Int:1300)) -Trying to set RedirectRequest for 7rgEnvHL to 127.0.0.1:4240 -Set RedirectRequest for 7rgEnvHL to 127.0.0.1:4240 -Sending message as: qZXgVJiD to: 4MHbSLnZ - Over: 127.0.0.1:4240 - Message: NNewValue (String:"qZXgVJiD") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray [VInt (Int:1300)]) (Int:0))) (String:"7rgEnvHL") (String:"nISByehk") (((String:"127.0.0.1") (String:"4343")))) -Trying to connect to: 127.0.0.1:4240 -Sending message as: 7tTIigo7 to: MiquZROF - Over: 127.0.0.1:4340 - Message: NIntroduceClient (String:"7tTIigo7") (String:"4343") (TName (Bool:False) (String:"SendSendIntClient")) (TSend (String:"#!") (TName (Bool:False) (String:"SendIntClient")) (TUnit)) -Trying to set RedirectRequest for nISByehk to 127.0.0.1:4340 -Set RedirectRequest for nISByehk to 127.0.0.1:4340 -Sending message as: 7tTIigo7 to: MiquZROF - Over: 127.0.0.1:4340 - Message: NNewValue (String:"7tTIigo7") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"nISByehk") (String:"7rgEnvHL") (((String:"127.0.0.1") (String:"4242")))) -Recieved message as: MiquZROF (4340) from: 7tTIigo7 - NConversationMessage (String:"r4mVhKcq") (NNewValue (String:"7tTIigo7") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1300)]) (Int:1))) (((SValuesArray [VInt (Int:1)]) (Int:0))) (String:"nISByehk") (String:"7rgEnvHL") (((String:"127.0.0.1") (String:"4242"))))) -Sending message as: 7rgEnvHL to: nISByehk - Over: 127.0.0.1:4242 - Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") -Trying to connect to: 127.0.0.1:4242 -Recieved message as: 4MHbSLnZ (4240) from: qZXgVJiD - NConversationMessage (String:"vn4kpvnc") (NNewValue (String:"qZXgVJiD") (Int:1) (VChanSerial (((SValuesArray [VInt (Int:1)]) (Int:1))) (((SValuesArray [VInt (Int:1300)]) (Int:0))) (String:"7rgEnvHL") (String:"nISByehk") (((String:"127.0.0.1") (String:"4343"))))) -Sending message as: nISByehk to: 7rgEnvHL - Over: 127.0.0.1:4343 - Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") -Trying to connect to: 127.0.0.1:4343 -Recieved message as: nISByehk (4242) from: 7rgEnvHL - NConversationMessage (String:"mc7wMrHY") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) -Found redirect request for: 7rgEnvHL -Send redirect to:127.0.0.1:4240 - Message: NConversationMessage (String:"mc7wMrHY") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) -Recieved message as: 7rgEnvHL (4343) from: nISByehk - NConversationMessage (String:"jzQaGVfj") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) -Found redirect request for: nISByehk -Send redirect to:127.0.0.1:4340 - Message: NConversationMessage (String:"jzQaGVfj") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) -Communication partner changed address, resending -Sending message as: 7rgEnvHL to: nISByehk - Over: 127.0.0.1:4240 - Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") -Trying to connect to: 127.0.0.1:4240 -Communication partner changed address, resending -Sending message as: nISByehk to: 7rgEnvHL - Over: 127.0.0.1:4340 - Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") -Trying to connect to: 127.0.0.1:4340 -Recieved message from unknown connection! - Message: NConversationMessage (String:"PiKTMZk3") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) -Recieved message from unknown connection! - Message: NConversationMessage (String:"Wgc8VSWd") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) -Communication out of sync lets wait! -Communication out of sync lets wait! -Sending message as: 7rgEnvHL to: nISByehk - Over: 127.0.0.1:4240 - Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") -Recieved message from unknown connection! - Message: NConversationMessage (String:"8tRv7zEU") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) -Sending message as: nISByehk to: 7rgEnvHL - Over: 127.0.0.1:4340 - Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") -Recieved message from unknown connection! - Message: NConversationMessage (String:"nsMTLUV5") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) -Communication out of sync lets wait! -Communication out of sync lets wait! -Sending message as: 7rgEnvHL to: nISByehk - Over: 127.0.0.1:4240 - Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") -Recieved message from unknown connection! - Message: NConversationMessage (String:"psB35Ww8") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) -Sending message as: nISByehk to: 7rgEnvHL - Over: 127.0.0.1:4340 - Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") -Recieved message from unknown connection! - Message: NConversationMessage (String:"NHp37pNy") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) -Communication out of sync lets wait! -Communication out of sync lets wait! -Sending message as: 7rgEnvHL to: nISByehk - Over: 127.0.0.1:4240 - Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") -Recieved message from unknown connection! - Message: NConversationMessage (String:"XGzPe347") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) -Sending message as: nISByehk to: 7rgEnvHL - Over: 127.0.0.1:4340 - Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") -Recieved message from unknown connection! - Message: NConversationMessage (String:"nc4kbQGE") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) -Communication out of sync lets wait! -Communication out of sync lets wait! -Sending message as: 7rgEnvHL to: nISByehk - Over: 127.0.0.1:4240 - Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") -Recieved message from unknown connection! - Message: NConversationMessage (String:"65nMnuAF") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) -Sending message as: nISByehk to: 7rgEnvHL - Over: 127.0.0.1:4340 - Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") -Recieved message from unknown connection! - Message: NConversationMessage (String:"gWXy1btd") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) -Communication out of sync lets wait! -Communication out of sync lets wait! -Sending message as: 7rgEnvHL to: nISByehk - Over: 127.0.0.1:4240 - Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") -Recieved message from unknown connection! - Message: NConversationMessage (String:"wsiXKJj6") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) -Sending message as: nISByehk to: 7rgEnvHL - Over: 127.0.0.1:4340 - Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") -Recieved message from unknown connection! - Message: NConversationMessage (String:"F8J2w78a") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) -Communication out of sync lets wait! -Communication out of sync lets wait! -^VSending message as: 7rgEnvHL to: nISByehk - Over: 127.0.0.1:4240 - Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") -Recieved message from unknown connection! - Message: NConversationMessage (String:"6e1XCkd1") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) -Sending message as: nISByehk to: 7rgEnvHL - Over: 127.0.0.1:4340 - Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") -Recieved message from unknown connection! - Message: NConversationMessage (String:"lFGrxfAz") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) -Communication out of sync lets wait! -Communication out of sync lets wait! -Sending message as: 7rgEnvHL to: nISByehk - Over: 127.0.0.1:4240 - Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") -Recieved message from unknown connection! - Message: NConversationMessage (String:"E7AhHqgg") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) -Sending message as: nISByehk to: 7rgEnvHL - Over: 127.0.0.1:4340 - Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") -Recieved message from unknown connection! - Message: NConversationMessage (String:"E8i7UHZA") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) -Communication out of sync lets wait! -Communication out of sync lets wait! -Sending message as: 7rgEnvHL to: nISByehk - Over: 127.0.0.1:4240 - Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") -Recieved message from unknown connection! - Message: NConversationMessage (String:"zXWZieG6") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) -Sending message as: nISByehk to: 7rgEnvHL - Over: 127.0.0.1:4340 - Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") -Recieved message from unknown connection! - Message: NConversationMessage (String:"jVfvJugy") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) -Communication out of sync lets wait! -Communication out of sync lets wait! -Sending message as: 7rgEnvHL to: nISByehk - Over: 127.0.0.1:4240 - Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") -Recieved message from unknown connection! - Message: NConversationMessage (String:"846ygNLv") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) -Sending message as: nISByehk to: 7rgEnvHL - Over: 127.0.0.1:4340 - Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") -Recieved message from unknown connection! - Message: NConversationMessage (String:"mGc2GaJY") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) -Communication out of sync lets wait! -Communication out of sync lets wait! -Sending message as: 7rgEnvHL to: nISByehk - Over: 127.0.0.1:4240 - Message: NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340") -Recieved message from unknown connection! - Message: NConversationMessage (String:"VUuwAOk8") (NIntroduceNewPartnerAddress (String:"7rgEnvHL") (String:"4340")) -Sending message as: nISByehk to: 7rgEnvHL - Over: 127.0.0.1:4340 - Message: NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240") -Recieved message from unknown connection! - Message: NConversationMessage (String:"WLnyAVFy") (NIntroduceNewPartnerAddress (String:"nISByehk") (String:"4240")) -Communication out of sync lets wait! -Communication out of sync lets wait! -^C[laeuferle@workbench ldgvnetworking]$ ^C -[laeuferle@workbench ldgvnetworking]$ ^C -[laeuferle@workbench ldgvnetworking]$ \ No newline at end of file diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index e6d9dff..8858d12 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -3,34 +3,23 @@ module Networking.Client where import qualified Config -import Networking.NetworkConnection as NCon import ProcessEnvironmentTypes -import qualified ValueParsing.ValueTokens as VT -import qualified ValueParsing.ValueGrammar as VG import Networking.Messages import qualified Control.Concurrent.MVar as MVar import qualified Networking.DirectionalConnection as DC -import Network.Socket import qualified Networking.Messages as Messages -import qualified Networking.NetworkConnection as Networking import qualified Networking.UserID as UserID import qualified Data.Map as Map -import GHC.IO.Handle import qualified Data.Maybe -import Networking.NetworkConnection import Control.Concurrent import Control.Exception -import GHC.Exception import qualified Syntax import qualified Networking.Common as NC -import qualified Networking.NetworkConnection as NCon -import qualified Control.Concurrent as MVar -import qualified Config +import Networking.NetworkConnection import qualified Networking.Serialize as NSerialize import Control.Monad import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC import qualified Control.Concurrent.SSem as SSem -import Networking.NetworkConnection (NetworkConnection(ncConnectionState)) newtype ClientException = NoIntroductionException String @@ -46,14 +35,13 @@ sendValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Valu sendValue vchanconsmvar activeCons networkconnection val ownport resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of - NCon.Connected hostname port _ _ _ -> do + Connected hostname port _ _ _ -> do setRedirectRequests vchanconsmvar hostname port ownport val valcleaned <- replaceVChan val DC.writeMessage (ncWrite networkconnection) valcleaned messagesCount <- DC.countMessages $ ncWrite networkconnection tryToSendNetworkMessage activeCons networkconnection hostname port (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) messagesCount valcleaned) resendOnError - -- disableVChans val - NCon.Emulated {} -> do + Emulated {} -> do vchancons <- MVar.readMVar vchanconsmvar valCleaned <- replaceVChan val DC.writeMessage (ncWrite networkconnection) valCleaned @@ -66,7 +54,6 @@ sendValue vchanconsmvar activeCons networkconnection val ownport resendOnError = _ -> do Config.traceNetIO "Something went wrong when sending over a emulated connection" return False - -- disableVChans val _ -> do Config.traceNetIO "Error when sending message: This channel is disconnected" return False @@ -75,9 +62,9 @@ sendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> Messag sendNetworkMessage activeCons networkconnection message resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of - NCon.Connected hostname port _ _ _ -> do + Connected hostname port _ _ _ -> do tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError - NCon.Emulated {} -> return True + Emulated {} -> return True _ -> do Config.traceNetIO "Error when sending message: This channel is disconnected" return False @@ -109,7 +96,6 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen return True Redirect host port -> do sendingNetLog serializedMessage "Communication partner changed address, resending" - -- NCon.changePartnerAddress networkconnection host port "" -- TODO properly fix this tryToSendNetworkMessage activeCons networkconnection host port message resendOnError Wait -> do sendingNetLog serializedMessage "Communication out of sync lets wait!" @@ -136,37 +122,6 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen sendingNetLog :: String -> String -> IO () sendingNetLog msg info = Config.traceNetIO $ "Sending message: "++msg++" \n Status: "++info -{- -setPartnerHostAddress :: String -> Value -> Value -setPartnerHostAddress address input = case input of - VSend v -> VSend $ setPartnerHostAddress address v - VPair v1 v2 -> - let nv1 = setPartnerHostAddress address v1 in - let nv2 = setPartnerHostAddress address v2 in - VPair nv1 nv2 - VFunc penv a b -> - let newpenv = setPartnerHostAddressPEnv address penv in - VFunc newpenv a b - VDynCast v g -> VDynCast (setPartnerHostAddress address v) g - VFuncCast v a b -> VFuncCast (setPartnerHostAddress address v) a b - VRec penv a b c d -> - let newpenv = setPartnerHostAddressPEnv address penv in - VRec newpenv a b c d - VNewNatRec penv a b c d e f g -> - let newpenv = setPartnerHostAddressPEnv address penv in - VNewNatRec newpenv a b c d e f g - VChanSerial r w p o c -> do - let (hostname, port) = c - VChanSerial r w p o (if hostname == "" then address else hostname, port) - _ -> input -- return input - where - setPartnerHostAddressPEnv :: String -> [(String, Value)] -> [(String, Value)] - setPartnerHostAddressPEnv _ [] = [] - setPartnerHostAddressPEnv clientHostaddress penvs@(x:xs) = - let newval = setPartnerHostAddress clientHostaddress $ snd x in - (fst x, newval):setPartnerHostAddressPEnv clientHostaddress xs --} - printConErr :: String -> String -> IOException -> IO Bool printConErr hostname port err = do Config.traceIO $ "Communication Partner " ++ hostname ++ ":" ++ port ++ "not found! \n " ++ show err @@ -230,8 +185,8 @@ setRedirectRequests vchanconmvar newhost newport ownport input = case input of SSem.withSem (ncHandlingIncomingMessage nc) (do oldconnectionstate <- MVar.takeMVar $ ncConnectionState nc case oldconnectionstate of - Connected hostname port partConID ownConID confirmed -> MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest hostname port newhost newport partConID ownConID confirmed - RedirectRequest hostname port _ _ partConID ownConID confirmed -> MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest hostname port newhost newport partConID ownConID confirmed + Connected hostname port partConID ownConID confirmed -> MVar.putMVar (ncConnectionState nc) $ RedirectRequest hostname port newhost newport partConID ownConID confirmed + RedirectRequest hostname port _ _ partConID ownConID confirmed -> MVar.putMVar (ncConnectionState nc) $ RedirectRequest hostname port newhost newport partConID ownConID confirmed Emulated partConID ownConID confirmed -> do Config.traceNetIO "TODO: Allow RedirectRequest for Emulated channel" vchanconnections <- MVar.takeMVar vchanconmvar @@ -240,9 +195,9 @@ setRedirectRequests vchanconmvar newhost newport ownport input = case input of let mbypartner = Map.lookup (Data.Maybe.fromMaybe "" userid) vchanconnections case mbypartner of Just partner -> do - MVar.putMVar (ncConnectionState nc) $ NCon.RedirectRequest "" ownport newhost newport partConID ownConID confirmed -- Setting this to 127.0.0.1 is a temporary hack + MVar.putMVar (ncConnectionState nc) $ RedirectRequest "" ownport newhost newport partConID ownConID confirmed -- Setting this to 127.0.0.1 is a temporary hack oldconectionstatePartner <- MVar.takeMVar $ ncConnectionState partner - MVar.putMVar (ncConnectionState partner) $ NCon.Connected newhost newport partConID ownConID confirmed + MVar.putMVar (ncConnectionState partner) $ Connected newhost newport partConID ownConID confirmed Nothing -> do MVar.putMVar (ncConnectionState nc) oldconnectionstate Config.traceNetIO "Error occured why getting the linked emulated channel" @@ -298,7 +253,6 @@ replaceVChan input = case input of sendDisconnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> IO () sendDisconnect ac mvar = do - --Config.traceNetIO "sendDisconnect" networkConnectionMap <- MVar.readMVar mvar let allNetworkConnections = Map.elems networkConnectionMap goodbyes <- doForall ac allNetworkConnections @@ -317,7 +271,6 @@ sendDisconnect ac mvar = do connectionState <- MVar.readMVar $ ncConnectionState con unreadVals <- DC.unreadMessageStart writeVals lengthVals <- DC.countMessages writeVals - --Config.traceNetIO $ show unreadVals ++ "/" ++ show lengthVals case connectionState of Connected host port _ _ _ -> if unreadVals >= lengthVals then do diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 7ccbcbd..802a4fa 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -1,14 +1,5 @@ -{-# LANGUAGE LambdaCase #-} - module Networking.Common where -import Network.Socket -import GHC.IO.Handle -import System.IO -import qualified Networking.Serialize as NSerialize -import qualified ValueParsing.ValueTokens as VT -import qualified ValueParsing.ValueGrammar as VG -import qualified Config -- import qualified Networking.NetworkingMethod.Stateless as NetMethod import qualified Networking.NetworkingMethod.Fast as NetMethod diff --git a/src/Networking/DirectionalConnection.hs b/src/Networking/DirectionalConnection.hs index edc1c08..ccb0f25 100644 --- a/src/Networking/DirectionalConnection.hs +++ b/src/Networking/DirectionalConnection.hs @@ -3,7 +3,6 @@ module Networking.DirectionalConnection where import Control.Concurrent.MVar import Control.Concurrent import qualified Control.Concurrent.SSem as SSem -import qualified System.Directory import Control.Monad data DirectionalConnection a = DirectionalConnection { messages :: MVar [a], messagesUnreadStart :: MVar Int, messagesCount :: MVar Int, readLock :: SSem.SSem} @@ -70,7 +69,7 @@ allMessages connection = readMVar (messages connection) readUnreadMessageMaybe :: DirectionalConnection a -> IO (Maybe a) readUnreadMessageMaybe connection = modifyMVar (messagesUnreadStart connection) (\i -> do messagesBind <- allMessages connection - if length messagesBind <= i then return (i, Nothing) else return ((i+1), Just (messagesBind!!i)) + if length messagesBind <= i then return (i, Nothing) else return (i+1, Just (messagesBind!!i)) ) -- Basically only used for the internal tests at this point diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index 60048ae..cb956d0 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -3,10 +3,8 @@ module Networking.NetworkingMethod.Fast where import Networking.NetworkingMethod.NetworkingMethodCommon import Network.Socket import GHC.IO.Handle -import System.IO import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.Chan as Chan -import qualified Data.Maybe import qualified Data.Map as Map import Control.Concurrent import Control.Monad @@ -16,8 +14,6 @@ import Networking.Messages import Networking.NetworkConnection import Networking.UserID import qualified Syntax -import qualified Networking.Serialize as NSerialize -import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG import qualified Config import qualified Networking.NetworkingMethod.Stateless as Stateless @@ -30,12 +26,6 @@ data Conversation = Conversation {convID :: String, convHandle :: Stateless.Conv type ConnectionHandler = ActiveConnectionsFast -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> Conversation -> String -> String -> Message -> IO () --- type NetworkAddress = (String, String) --- deriving (Eq, Show, Ord) - --- type Connectionhandler = MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, Syntax.Type)] -> (Socket, SockAddr) -> Handle -> String -> String -> Messages -> IO () - - sendMessage :: Conversation -> Message -> IO () sendMessage conv value = SSem.withSem (convSending conv) $ Stateless.sendMessage (convHandle conv) (ConversationMessage (convID conv) value) @@ -68,10 +58,7 @@ conversationHandlerChangeHandle handle chan mvar sem = do Config.traceNetIO $ "Recieved Message: " ++ mes MVar.takeMVar isClosed MVar.putMVar isClosed True - forkIO $ catch (do - -- closed <- hIsClosed $ fst handle - -- unless closed $ - hClose $ fst handle) onException + forkIO $ catch (hClose $ fst handle) onException return () ) ) @@ -87,22 +74,14 @@ conversationHandlerChangeHandle handle chan mvar sem = do onException :: IOException -> IO () onException _ = return () - - recieveResponse :: Conversation -> Int -> Int -> IO (Maybe Response) recieveResponse conv waitTime tries = do - -- Config.traceNetIO "Trying to take mvar for responses mvar" responsesMap <- MVar.readMVar $ convRespMap conv - -- Config.traceNetIO "Got MVar for responses" case Map.lookup (convID conv) responsesMap of Just (messages, deserial) -> do - -- MVar.putMVar (convRespMap conv) $ Map.delete (convID conv) responsesMap return $ Just deserial Nothing -> do - -- MVar.putMVar (convRespMap conv) responsesMap - -- handleClosed <- hIsClosed $ fst (convHandle conv) - if tries /= 0 {-&& not handleClosed-} then do - -- Config.traceNetIO "Nothing yet retrying!" + if tries /= 0 then do threadDelay waitTime recieveResponse conv waitTime $ max (tries-1) (-1) else return Nothing @@ -111,7 +90,6 @@ recieveNewMessage connection@(handle, isClosed, chan, mvar, sem) = do (cid, (serial, deserial)) <- Chan.readChan chan return (Conversation cid handle mvar sem, serial, deserial) - startConversation :: ActiveConnectionsFast -> String -> String -> Int -> Int -> IO (Maybe Conversation) startConversation acmvar hostname port waitTime tries = do conversationid <- newRandomUserID @@ -158,7 +136,6 @@ createActiveConnections = do MVar.putMVar activeConnections Map.empty return activeConnections - acceptConversations :: ActiveConnectionsFast -> ConnectionHandler -> Int -> MVar.MVar (Map.Map Int ServerSocket) -> VChanConnections -> IO ServerSocket acceptConversations ac connectionhandler port socketsmvar vchanconnections = do sockets <- MVar.takeMVar socketsmvar @@ -177,7 +154,6 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do where createServer :: ActiveConnectionsFast -> ConnectionHandler -> Int -> VChanConnections -> IO (MVar.MVar [(String, (Syntax.Type, Syntax.Type))]) createServer activeCons connectionhandler port vchanconnections = do - -- serverid <- UserID.newRandomUserID sock <- socket AF_INET Stream 0 setSocketOption sock ReuseAddr 1 let hints = defaultHints { @@ -207,14 +183,11 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do hdl <- Stateless.getHandleFromSocket $ fst clientsocket let statelessConv = (hdl, clientsocket) connection@(handle, isClosed, chan, responsesMvar, sem) <- conversationHandler statelessConv - -- NC.recieveMessage hdl VG.parseMessages (\_ -> return ()) $ connectionhandler mvar clientlist clientsocket hdl ownport forkIO $ forever (do (conversationid, (serial, deserial)) <- Chan.readChan chan connectionhandler activeCons mvar clientlist clientsocket (Conversation conversationid statelessConv responsesMvar sem) ownport serial deserial ) return () - -- hClose hdl - endConversation :: Conversation -> Int -> Int -> IO () endConversation _ _ _ = return () @@ -242,9 +215,5 @@ sayGoodbye activeCons = do onException :: IOException -> IO () onException _ = return () - -{-isClosed :: Conversation -> IO Bool -isClosed = hIsClosed . fst . convHandle-} - getPartnerHostaddress :: Conversation -> String getPartnerHostaddress = Stateless.getPartnerHostaddress . convHandle diff --git a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs index 72b1217..c51e3f7 100644 --- a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs +++ b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs @@ -17,7 +17,7 @@ data ActiveConnectionsStateless = ActiveConnectionsStateless type ConversationStateless = (Handle, (Socket, SockAddr)) type Connection = (ConversationStateless, MVar.MVar Bool, Chan.Chan (String, (String, Message)), MVar.MVar (Map.Map String (String, Response)), SSem.SSem) --- isClosed Conversationid serial deserial +-- isClosed Conversationid serial deserial type ActiveConnectionsFast = MVar.MVar (Map.Map NetworkAddress Connection) type NetworkAddress = (String, String) diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index bc60f9c..02cdad0 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -7,22 +7,18 @@ import GHC.IO.Handle import System.IO import qualified Control.Concurrent.MVar as MVar import qualified Data.Map as Map -import qualified Data.Maybe import Control.Concurrent import Control.Monad import Control.Exception import Networking.Messages import Networking.NetworkConnection -import qualified Networking.DirectionalConnection as DC import ProcessEnvironmentTypes import qualified Networking.Serialize as NSerialize import qualified ValueParsing.ValueTokens as VT import qualified ValueParsing.ValueGrammar as VG import qualified Config import qualified Syntax -import qualified Networking.DirectionalConnection as DC -import qualified Networking.DirectionalConnection as DC type ConnectionHandler = ActiveConnectionsStateless -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> Conversation -> String -> String -> Message -> IO () @@ -45,7 +41,6 @@ recieveMessageInternal conv@(handle, _) grammar fallbackResponse messageHandler Config.traceNetIO $ "Error during recieving a networkmessage: "++err++" Malformed message: " ++ message fallbackResponse message Right deserialmessage -> do - -- Config.traceNetIO $ "New superficially valid message recieved: "++message messageHandler message deserialmessage @@ -110,7 +105,6 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do where createServer :: ActiveConnectionsStateless -> ConnectionHandler -> Int -> VChanConnections -> IO (MVar.MVar [(String, (Syntax.Type, Syntax.Type))]) createServer activeCons connectionhandler port vchanconnections = do - -- serverid <- UserID.newRandomUserID sock <- socket AF_INET Stream 0 setSocketOption sock ReuseAddr 1 let hints = defaultHints { @@ -121,17 +115,13 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do addrInfo <- getAddrInfo (Just hints) Nothing $ Just $ show port bind sock $ addrAddress $ head addrInfo listen sock 1024 - -- mvar <- MVar.newEmptyMVar - -- MVar.putMVar mvar Map.empty clientlist <- MVar.newEmptyMVar MVar.putMVar clientlist [] forkIO $ acceptClients activeCons connectionhandler vchanconnections clientlist sock $ show port return clientlist acceptClients :: ActiveConnectionsStateless -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> Socket -> String -> IO () acceptClients activeCons connectionhandler mvar clientlist socket ownport = do - Config.traceIO "Waiting for clients" clientsocket <- accept socket - Config.traceIO "Accepted new client" forkIO $ acceptClient activeCons connectionhandler mvar clientlist clientsocket ownport acceptClients activeCons connectionhandler mvar clientlist socket ownport @@ -143,8 +133,6 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do recieveMessageInternal conv VG.parseMessages (\_ -> return ()) $ connectionhandler activeCons mvar clientlist clientsocket conv ownport hClose hdl - - getFromNetworkThread :: Maybe Conversation -> ThreadId -> MVar.MVar a -> Int -> Int -> IO (Maybe a) getFromNetworkThread conv = getFromNetworkThreadWithModification conv Just @@ -154,8 +142,7 @@ getFromNetworkThreadWithModification conv func threadid mvar waitTime currentTry case mbyResult of Just result -> return $ func result Nothing -> do - -- convClosed <- Data.Maybe.maybe (return False) (hIsClosed . fst) conv - if currentTry /= 0 {-&& not convClosed-} then do + if currentTry /= 0 then do threadDelay waitTime getFromNetworkThreadWithModification conv func threadid mvar waitTime $ max (currentTry-1) (-1) else do @@ -195,10 +182,6 @@ getHandleFromSocket socket = do sayGoodbye :: ActiveConnectionsStateless -> IO () sayGoodbye _ = return () - - -{-isClosed :: Conversation -> IO Bool -isClosed = hIsClosed . fst-} hostaddressTypeToString :: HostAddress -> String hostaddressTypeToString hostaddress = do diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index eac9250..3721bc1 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -217,12 +217,6 @@ instance Serializable Bool where instance Serializable Double where serialize d = return $ "Double:" ++ show d --- instance (Serializable a => Serializable (Set a)) where --- serialize as = "{" ++ serializeElements (elems as) ++ "}" - --- instance {-# OVERLAPPABLE #-} (Serializable a => Serializable [a]) where --- serialize arr = "["++ serializeElements arr ++"]" - instance ((Serializable a, Serializable b) => Serializable (a, b)) where serialize (s, t) = do ss <- serialize s diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index c6df42a..5424cad 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -1,51 +1,31 @@ -{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Redundant return" #-} module Networking.Server where import qualified Control.Concurrent.MVar as MVar -import qualified Control.Concurrent.Chan as Chan -import Control.Monad.IO.Class import qualified Data.Map as Map import qualified Data.Maybe -import GHC.IO.Handle import Network.Socket import Control.Concurrent import Networking.Messages -import qualified ValueParsing.ValueTokens as VT -import qualified ValueParsing.ValueGrammar as VG import qualified Networking.Common as NC import qualified Networking.Serialize as NSerialize import ProcessEnvironmentTypes import qualified Syntax -import Control.Exception import qualified Networking.UserID as UserID import qualified Networking.Messages as Messages -import qualified Networking.DirectionalConnection as ND import qualified Networking.Client as NClient import Networking.NetworkConnection -import qualified Networking.Common as NC import qualified Config import qualified Networking.NetworkConnection as NCon -import qualified Control.Concurrent as MVar -import qualified Networking.Client as NC import Control.Monad import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC import qualified Control.Concurrent.SSem as SSem import qualified Networking.DirectionalConnection as DC -import qualified Networking.NetworkConnection as NCon -import qualified Networking.DirectionalConnection as DC -import Networking.NetworkingMethod.Stateless (recieveMessageInternal) -import qualified Networking.Client as NClient -import qualified Networking.DirectionalConnection as NCon -import Networking.NetworkConnection (NetworkConnection(ncRead)) -import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC -import Control.Concurrent (threadDelay) -import qualified Networking.Client as NClient checkAndSendRedirectRequest :: NC.ConversationOrHandle -> Map.Map String (NetworkConnection Value) -> String -> IO Bool checkAndSendRedirectRequest handle ncmap userid = do @@ -79,13 +59,13 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria NC.sendResponse hdl (Messages.Redirect host port) Connected {} -> case deserialmessages of NewValue userid count val -> do - ND.lockInterpreterReads (ncRead networkcon) - ND.writeMessageIfNext (ncRead networkcon) count $ setPartnerHostAddress clientHostaddress val + DC.lockInterpreterReads (ncRead networkcon) + DC.writeMessageIfNext (ncRead networkcon) count $ setPartnerHostAddress clientHostaddress val SSem.signal $ ncHandlingIncomingMessage networkcon recievedNetLog message "Message written to Channel" NC.sendResponse hdl Messages.Okay recievedNetLog message "Sent okay" - ND.unlockInterpreterReads (ncRead networkcon) + DC.unlockInterpreterReads (ncRead networkcon) RequestValue userid count -> do SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Okay @@ -290,17 +270,7 @@ replaceVChanSerial activeCons mvar input = case input of VChanSerial r w p o c -> do networkconnection <- createNetworkConnection r w p o c ncmap <- MVar.takeMVar mvar - {- - case Map.lookup p ncmap of - Just networkcon -> do - connectionState <- MVar.readMVar $ ncConnectionState networkcon - MVar.takeMVar $ ncConnectionState networkconnection - MVar.putMVar (ncConnectionState networkconnection) connectionState - Nothing -> return () - -} - MVar.putMVar mvar $ Map.insert p networkconnection ncmap - -- NClient.sendNetworkMessage activeCons networkconnection (RequestSync o $ length r) 5 used<- MVar.newEmptyMVar MVar.putMVar used False return $ VChan networkconnection used @@ -341,12 +311,12 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do Config.traceNetIO $ show connectionState _ -> return () - msgCount <- NCon.unreadMessageStart $ ncRead networkconnection + msgCount <- DC.unreadMessageStart $ ncRead networkconnection Config.traceNetIO "Trying to acknowledge message" NClient.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) msgCount) $ -1 return val Nothing -> if count == 0 then do - msgCount <- NCon.countMessages $ ncRead networkconnection + msgCount <- DC.countMessages $ ncRead networkconnection NClient.sendNetworkMessage activeCons networkconnection (Messages.RequestValue (Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) msgCount) 0 recieveValueInternal 100 vchanconsvar activeCons networkconnection ownport else do @@ -373,7 +343,7 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do Config.traceNetIO $ show connectionState _ -> return () - msgCount <- NCon.unreadMessageStart $ ncRead networkconnection + msgCount <- DC.unreadMessageStart $ ncRead networkconnection Config.traceNetIO "Trying to acknowledge message" vchancons <- MVar.readMVar vchanconsvar let partnerid = Data.Maybe.fromMaybe "" $ ncPartnerUserID networkconnection diff --git a/src/Networking/UserID.hs b/src/Networking/UserID.hs index f267bca..1c132bf 100644 --- a/src/Networking/UserID.hs +++ b/src/Networking/UserID.hs @@ -10,7 +10,6 @@ mapToChar val | 36 <= val && val <= 61 = chr (val + 61) | otherwise = '-' --- This is "probably" unique newRandomUserID :: IO String newRandomUserID = map mapToChar . take 8 . randomRs (0, 61) <$> newStdGen -- newRandomUserID = map mapToChar . take 128 . randomRs (0, 61) <$> newStdGen From f0102f19d9026bffaad785c9dd74d871df30f17a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 14 Feb 2023 16:41:10 +0100 Subject: [PATCH 146/229] Removed unnecessary code II --- ldgv.cabal | 2 +- src/Interpreter.hs | 32 +---------------------- src/Networking/Client.hs | 4 +-- src/Networking/NetworkConnection.hs | 16 +++++------- src/Networking/NetworkingMethod/Fast.hs | 12 ++------- src/Networking/{UserID.hs => RandomID.hs} | 6 ++--- src/Networking/Server.hs | 5 ++-- 7 files changed, 17 insertions(+), 60 deletions(-) rename src/Networking/{UserID.hs => RandomID.hs} (70%) diff --git a/ldgv.cabal b/ldgv.cabal index 2525a08..d7f5f92 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -74,9 +74,9 @@ library Networking.NetworkingMethod.Fast Networking.NetworkingMethod.NetworkingMethodCommon Networking.NetworkingMethod.Stateless + Networking.RandomID Networking.Serialize Networking.Server - Networking.UserID Parsing Parsing.Grammar Parsing.Tokens diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 72116c9..a38b9e1 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -11,13 +11,8 @@ module Interpreter import qualified Config as C import Syntax import PrettySyntax -import qualified Control.Concurrent.Chan as Chan import qualified Control.Concurrent.MVar as MVar -import Network.Socket --- import qualified Network.Socket as NSocket -import Control.Concurrent (forkIO) import Data.Foldable (find) -import Data.Maybe (fromJust, fromMaybe) import qualified Data.Map as Map import ProcessEnvironment import Networking.NetworkingMethod.NetworkingMethodCommon @@ -27,42 +22,17 @@ import Control.Applicative ((<|>)) import Control.Exception import Kinds (Multiplicity(..)) -import qualified ValueParsing.ValueTokens as VT -import qualified ValueParsing.ValueGrammar as VG import qualified Networking.Common as NC import qualified Networking.Client as NClient - -import Network.Run.TCP import qualified Networking.Server as NS -import Networking.UserID as UserID import Control.Concurrent -import qualified Networking.UserID as UserID - -import qualified Networking.Messages as Messages import qualified Networking.DirectionalConnection as DC import qualified Networking.NetworkConnection as NCon -import qualified Networking.Serialize --- import ProcessEnvironment (CommunicationChannel(CommunicationChannel, ccChannelState, ccPartnerUserID), ConnectionInfo (ciReadChannel, ciWriteChannel)) --- import ProcessEnvironment -import qualified Control.Concurrent as MVar -import ProcessEnvironment import ProcessEnvironmentTypes -import Networking.NetworkConnection (NetworkConnection(ncPartnerUserID)) -import qualified Control.Concurrent as MVar -import qualified Control.Concurrent as MVar -import qualified Control.Concurrent as MVar -import qualified Control.Concurrent as MVar -import qualified Control.Concurrent as MVar -import qualified Control.Concurrent as MVar -import qualified Control.Concurrent.SSem as SSem --- import qualified Networking.NetworkConnection as NCon --- import qualified Networking.NetworkConnection as NCon - import qualified Data.Bifunctor --- import qualified Networking.NetworkingMethod.Stateless as NetMethod --- import qualified Networking.NetworkingMethod.Fast as NetMethod +import Data.Maybe data InterpreterException = MathException String diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 8858d12..07fee60 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -8,7 +8,7 @@ import Networking.Messages import qualified Control.Concurrent.MVar as MVar import qualified Networking.DirectionalConnection as DC import qualified Networking.Messages as Messages -import qualified Networking.UserID as UserID +import qualified Networking.RandomID as RandomID import qualified Data.Map as Map import qualified Data.Maybe import Control.Concurrent @@ -134,7 +134,7 @@ initialConnect activeCons mvar hostname port ownport syntype= do case mbycon of Just con -> do - ownuserid <- UserID.newRandomUserID + ownuserid <- RandomID.newRandomID NC.sendMessage con (Messages.IntroduceClient ownuserid ownport (fst syntype) $ snd syntype) mbyintroductionanswer <- NC.recieveResponse con 10000 (-1) NC.endConversation con 10000 10 diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index 21290cb..d9fb6f0 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -1,11 +1,7 @@ module Networking.NetworkConnection where import Networking.DirectionalConnection - ( DirectionalConnection, - newConnection, - createConnection, - serializeConnection ) -import Networking.UserID +import Networking.RandomID import qualified Data.Maybe import qualified Data.Map as Map import qualified Control.Concurrent.MVar as MVar @@ -34,7 +30,7 @@ createNetworkConnection :: ([a], Int) -> ([a], Int) -> String -> String -> (Stri createNetworkConnection (readList, readNew) (writeList, writeNew) partnerID ownID (hostname, port, partnerConnectionID) = do read <- createConnection readList readNew write <- createConnection writeList writeNew - ownConnectionID <- newRandomUserID + ownConnectionID <- newRandomID connectionstate <- MVar.newMVar $ Connected hostname port partnerConnectionID ownConnectionID False incomingMsg <- SSem.new 1 return $ NetworkConnection read write (Just partnerID) (Just ownID) connectionstate incomingMsg @@ -47,12 +43,12 @@ newEmulatedConnection mvar = do write <- newConnection read2 <- newConnection write2 <- newConnection - connectionid1 <- newRandomUserID - connectionid2 <- newRandomUserID + connectionid1 <- newRandomID + connectionid2 <- newRandomID connectionstate <- MVar.newMVar $ Emulated connectionid2 connectionid1 True connectionstate2 <- MVar.newMVar $ Emulated connectionid1 connectionid2 True - userid <- newRandomUserID - userid2 <- newRandomUserID + userid <- newRandomID + userid2 <- newRandomID incomingMsg <- SSem.new 1 incomingMsg2 <- SSem.new 1 let nc1 = NetworkConnection read write (Just userid2) (Just userid) connectionstate incomingMsg diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index cb956d0..9f80889 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -12,7 +12,7 @@ import Control.Exception import Networking.Messages import Networking.NetworkConnection -import Networking.UserID +import Networking.RandomID import qualified Syntax import qualified ValueParsing.ValueGrammar as VG import qualified Config @@ -44,16 +44,12 @@ conversationHandlerChangeHandle handle chan mvar sem = do isClosed <- MVar.newEmptyMVar MVar.putMVar isClosed False forkIO $ whileNotMVar isClosed (do - Config.traceNetIO "Waiting for new conversation" Stateless.recieveMessageInternal handle VG.parseConversation (\_ -> return ()) (\mes des -> do - Config.traceNetIO $ "Got new conversation: " ++ mes case des of ConversationMessage cid message -> Chan.writeChan chan (cid, (mes, message)) ConversationResponse cid response -> do - Config.traceNetIO "Trying to take mvar" mymap <- MVar.takeMVar mvar MVar.putMVar mvar $ Map.insert cid (mes, response) mymap - Config.traceNetIO "Set responses mvar" ConversationCloseAll -> do Config.traceNetIO $ "Recieved Message: " ++ mes MVar.takeMVar isClosed @@ -92,7 +88,7 @@ recieveNewMessage connection@(handle, isClosed, chan, mvar, sem) = do startConversation :: ActiveConnectionsFast -> String -> String -> Int -> Int -> IO (Maybe Conversation) startConversation acmvar hostname port waitTime tries = do - conversationid <- newRandomUserID + conversationid <- newRandomID connectionMap <- MVar.takeMVar acmvar case Map.lookup (hostname, port) connectionMap of Just (handle, isClosed, chan, mvar, sem) -> do @@ -144,9 +140,7 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do MVar.putMVar socketsmvar sockets return socket Nothing -> do - Config.traceIO "Creating socket!" clientlist <- createServer ac connectionhandler port vchanconnections - Config.traceIO "Socket created" let newsocket = (clientlist, show port) let updatedMap = Map.insert port newsocket sockets MVar.putMVar socketsmvar updatedMap @@ -171,9 +165,7 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do acceptClients :: ActiveConnectionsFast -> ConnectionHandler -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> Socket -> String -> IO () acceptClients activeCons connectionhandler mvar clientlist socket ownport = do - Config.traceIO "Waiting for clients" clientsocket <- accept socket - Config.traceIO "Accepted new client" forkIO $ acceptClient activeCons connectionhandler mvar clientlist clientsocket ownport acceptClients activeCons connectionhandler mvar clientlist socket ownport diff --git a/src/Networking/UserID.hs b/src/Networking/RandomID.hs similarity index 70% rename from src/Networking/UserID.hs rename to src/Networking/RandomID.hs index 1c132bf..557e0e0 100644 --- a/src/Networking/UserID.hs +++ b/src/Networking/RandomID.hs @@ -1,4 +1,4 @@ -module Networking.UserID where +module Networking.RandomID where import Data.Char import System.Random @@ -10,6 +10,6 @@ mapToChar val | 36 <= val && val <= 61 = chr (val + 61) | otherwise = '-' -newRandomUserID :: IO String -newRandomUserID = map mapToChar . take 8 . randomRs (0, 61) <$> newStdGen +newRandomID :: IO String +newRandomID = map mapToChar . take 8 . randomRs (0, 61) <$> newStdGen -- newRandomUserID = map mapToChar . take 128 . randomRs (0, 61) <$> newStdGen diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 5424cad..b48f2ed 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -14,7 +14,7 @@ import qualified Networking.Serialize as NSerialize import ProcessEnvironmentTypes import qualified Syntax -import qualified Networking.UserID as UserID +import qualified Networking.RandomID as RandomID import qualified Networking.Messages as Messages import qualified Networking.Client as NClient @@ -46,7 +46,6 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria case Map.lookup userid netcons of Just networkcon -> do recievedNetLog message $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " (" ++ ownport ++ ") from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) - -- Config.traceNetIO $ " "++message busy <- SSem.tryWait $ ncHandlingIncomingMessage networkcon case busy of Just num -> do @@ -110,7 +109,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria recievedNetLog message "Recieved message from unknown connection" case deserialmessages of IntroduceClient userid clientport synname syntype -> do - serverid <- UserID.newRandomUserID + serverid <- RandomID.newRandomID newpeer <- newNetworkConnection userid serverid clientHostaddress clientport userid serverid NC.sendResponse hdl (Messages.OkayIntroduce serverid) repserial <- NSerialize.serialize $ Messages.OkayIntroduce serverid From 70a1a73f452c21d73336ee4c188d63ca6a223364 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 14 Feb 2023 17:02:11 +0100 Subject: [PATCH 147/229] Removed unnecessary code III --- src/Config.hs | 8 -------- src/Networking/Server.hs | 14 +------------- src/PrettySyntax.hs | 4 +--- 3 files changed, 2 insertions(+), 24 deletions(-) diff --git a/src/Config.hs b/src/Config.hs index d714365..46a2e22 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -16,14 +16,6 @@ debugLevel :: DebugLevel debugLevel = DebugNetwork --debugLevel = DebugNone -{- -data NetworkingMethod = NetworkingStateless | NetworkingFast - deriving (Eq, Ord, Show) - -networkingMethod :: NetworkingMethod -networkingMethod = NetworkingStateless --} - trace :: String -> a -> a trace s a | debugLevel > DebugNetwork = D.trace s a | otherwise = a diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index b48f2ed..691d9d6 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -25,13 +25,7 @@ import Control.Monad import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC import qualified Control.Concurrent.SSem as SSem -import qualified Networking.DirectionalConnection as DC - -checkAndSendRedirectRequest :: NC.ConversationOrHandle -> Map.Map String (NetworkConnection Value) -> String -> IO Bool -checkAndSendRedirectRequest handle ncmap userid = do - case Map.lookup userid ncmap of - Nothing -> return False - +import qualified Networking.DirectionalConnection as DC handleClient :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> Message -> IO () handleClient activeCons mvar clientlist clientsocket hdl ownport message deserialmessages = do @@ -135,8 +129,6 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria recievedNetLog :: String -> String -> IO () recievedNetLog msg info = Config.traceNetIO $ "Recieved message: "++msg++" \n Status: "++info - - setPartnerHostAddress :: String -> Value -> Value setPartnerHostAddress address input = case input of VSend v -> VSend $ setPartnerHostAddress address v @@ -282,7 +274,6 @@ replaceVChanSerial activeCons mvar input = case input of rest <- replaceVChanSerialPEnv activeCons mvar xs return $ (fst x, newval):rest - recieveValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value recieveValue vchanconsvar activeCons networkconnection ownport = do connectionState <- MVar.readMVar $ ncConnectionState networkconnection @@ -294,7 +285,6 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do recieveValueInternal count vchanconsvar activeCons networkconnection ownport = do let readDC = ncRead networkconnection mbyUnclean <- DC.readUnreadMessageInterpreter readDC - -- Config.traceNetIO $ "Current unreadMSG:" ++ show mbyUnclean case mbyUnclean of Just unclean -> do Config.traceNetIO "Preparing value" @@ -325,8 +315,6 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do recieveValueEmulated vchanconsvar activeCons networkconnection ownport = do let readDC = ncRead networkconnection mbyUnclean <- DC.readUnreadMessageInterpreter readDC - -- allValues <- DC.allMessages $ ncWrite networkconnection - -- Config.traceNetIO $ "all Values: "++ show allValues case mbyUnclean of Just unclean -> do Config.traceNetIO "Preparing value" diff --git a/src/PrettySyntax.hs b/src/PrettySyntax.hs index 123e2f0..c33b086 100644 --- a/src/PrettySyntax.hs +++ b/src/PrettySyntax.hs @@ -6,7 +6,6 @@ module PrettySyntax (Pretty(), pretty, pshow) where import Kinds import Syntax -import ProcessEnvironment import ProcessEnvironmentTypes import Data.Text.Prettyprint.Doc @@ -169,7 +168,7 @@ instance Pretty Value where VDouble d -> pretty $ show d VString s -> pretty $ show s VChan {} -> pretty "VChan" - -- VChanSerial {} -> pretty "VChanSerial" + VChanSerial {} -> pretty "VChanSerial" VSend v -> pretty "VSend" VPair a b -> pretty "<" <+> pretty a <+> pretty ", " <+> pretty b <+> pretty ">" VType t -> pretty t @@ -178,7 +177,6 @@ instance Pretty Value where VFuncCast v ft1 ft2 -> pretty "(" <+> pretty v <+> pretty " : " <+> pretty ft1 <+> pretty " ⇒ " <+> pretty ft2 <+> pretty ")" VRec {} -> pretty "VRec" VNewNatRec {} -> pretty "VNewNatRec" - VServerSocket {}-> pretty "VServerSocket" instance Pretty FuncType where pretty (FuncType _ s t1 t2) = pretty "Π(" <+> pretty s <+> pretty ":" <+> pretty t1 <+> pretty ")" <+> pretty t2 From 2dcde5230e768c78fa3c1f8fc1ac93d19238d5c8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 14 Feb 2023 17:04:10 +0100 Subject: [PATCH 148/229] Removed unnecessary code IV --- src/Networking/Serialize.hs | 2 - src/ProcessEnvironmentTypes.hs | 67 ---------------------------------- 2 files changed, 69 deletions(-) diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index 3721bc1..fa18ff3 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -90,8 +90,6 @@ instance Serializable Value where VFuncCast v ft1 ft2 -> serializeLabeledEntryMulti "VFuncCast" v $ sNext ft1 $ sLast ft2 VRec env f x e0 e1 -> serializeLabeledEntryMulti "VRec" env $ sNext f $ sNext x $ sNext e0 $ sLast e1 VNewNatRec env f n tid ty ez x es -> serializeLabeledEntryMulti "VNewNatRec" env $ sNext f $ sNext n $ sNext tid $ sNext ty $ sNext ez $ sNext x $ sLast es - - VServerSocket {} -> throw $ UnserializableException "VServerSocket" VChan nc _-> serializeLabeledEntry "VChan" nc VChanSerial r w p o c -> serializeLabeledEntryMulti "VChanSerial" r $ sNext w $ sNext p $ sNext o $ sLast c diff --git a/src/ProcessEnvironmentTypes.hs b/src/ProcessEnvironmentTypes.hs index c88a9ae..5c9ae3f 100644 --- a/src/ProcessEnvironmentTypes.hs +++ b/src/ProcessEnvironmentTypes.hs @@ -10,13 +10,7 @@ import Data.Map as Map import qualified Data.Set as Set import Kinds (Multiplicity(..)) -import qualified Data.Maybe - -import Networking.DirectionalConnection import qualified Networking.NetworkConnection as NCon --- import qualified Networking.Common as NC - -import Network.Socket extendEnv :: String -> Value -> PEnv -> PEnv extendEnv = curry (:) @@ -63,8 +57,6 @@ data Value | VFuncCast Value FuncType FuncType -- (Value : (ρ,α,Π(x:A)A') => (ρ,α,Π(x:B)B')) | VRec PEnv String String Exp Exp | VNewNatRec PEnv String String String Type Exp String Exp - | VServerSocket (MVar.MVar (Map.Map String (NCon.NetworkConnection Value))) (MVar.MVar [(String, Type)]) String - -- Own Port Number deriving Eq disableOldVChan :: Value -> IO Value @@ -77,64 +69,6 @@ disableOldVChan value = case value of return $ VChan nc unused _ -> return value - -{- -disableVChan :: Value -> IO () -disableVChan value = case value of - VChan nc _ -> do - mbystate <- MVar.tryTakeMVar $ NCon.ncConnectionState nc --I dont fully understand why this mvar isnt filled but lets bypass this problem - case mbystate of - Nothing -> MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected - Just state -> case state of - NCon.Connected {} -> MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected - NCon.Emulated {} -> MVar.putMVar (NCon.ncConnectionState nc) NCon.Disconnected - _ -> MVar.putMVar (NCon.ncConnectionState nc) state - _ -> return () - - - -disableVChans :: Value -> IO () -disableVChans input = case input of - VSend v -> do - nv <- disableVChans v - return () - -- return $ VSend nv - VPair v1 v2 -> do - nv1 <- disableVChans v1 - nv2 <- disableVChans v2 - return () - -- return $ VPair nv1 nv2 - VFunc penv a b -> do - newpenv <- disableVChansPEnv penv - return () - -- return $ VFunc newpenv a b - VDynCast v g -> do - nv <- disableVChans v - return () - -- return $ VDynCast nv g - VFuncCast v a b -> do - nv <- disableVChans v - return () - -- return $ VFuncCast nv a b - VRec penv a b c d -> do - newpenv <- disableVChansPEnv penv - return () - -- return $ VRec newpenv a b c d - VNewNatRec penv a b c d e f g -> do - newpenv <- disableVChansPEnv penv - return () - -- return $ VNewNatRec newpenv a b c d e f g - _ -> disableVChan input -- This handles vchans and the default case - where - disableVChansPEnv :: [(String, Value)] -> IO () - disableVChansPEnv [] = return () - disableVChansPEnv (x:xs) = do - newval <- disableVChans $ snd x - rest <- disableVChansPEnv xs - return () - -- return $ (fst x, newval):rest --} - instance Show Value where show = \case VUnit -> "VUnit" @@ -152,7 +86,6 @@ instance Show Value where VFuncCast v ft1 ft2 -> "VFuncCast (" ++ show v ++ ") (" ++ show ft1 ++ ") (" ++ show ft2 ++ ")" VRec env f x e1 e0 -> "VRec " ++ " " ++ f ++ " " ++ x ++ " " ++ show e1 ++ " " ++ show e0 VNewNatRec env f n tid ty ez x es -> "VNewNatRec " ++ f ++ n ++ tid ++ show ty ++ show ez ++ x ++ show es - VServerSocket {} -> "VServerSocket" class Subtypeable t where isSubtypeOf :: t -> t -> Bool From 52323e465d33d7a6c714397a78b2146e142b210e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 14 Feb 2023 17:11:53 +0100 Subject: [PATCH 149/229] Removed unnecessary code V --- src/Interpreter.hs | 27 +-------------------------- 1 file changed, 1 insertion(+), 26 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index a38b9e1..2d73f2c 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -184,31 +184,20 @@ eval = \case return $ VPair val newV Case e cases -> interpret' e >>= \(VLabel s) -> interpret' $ fromJust $ lookup s cases Accept e tname -> do - liftIO $ C.traceIO "Accepting new client!" - val <- interpret' e case val of VInt port -> do (env, (sockets, vchanconnections, activeConnections)) <- ask (clientlist, ownport) <- liftIO $ NC.acceptConversations activeConnections NS.handleClient port sockets vchanconnections - -- newuser <- liftIO $ Chan.readChan chan - liftIO $ C.traceIO "Searching for correct communicationpartner" - - t <- case tname of TName _ s -> maybe (throw $ LookupException s) (\(VType t) -> return t) (lookup s env) _ -> return tname - -- tserial <- liftIO $ Networking.Serialize.serialize t - -- C.traceNetIO $ "Interpreter: " ++ tserial - - newuser <- liftIO $ NS.findFittingClient clientlist (tname, t) -- There is still an issue - liftIO $ C.traceIO "Client accepted" + newuser <- liftIO $ NS.findFittingClient clientlist (tname, t) networkconnectionmap <- liftIO $ MVar.readMVar vchanconnections case Map.lookup newuser networkconnectionmap of Nothing -> throw $ CommunicationPartnerNotFoundException newuser Just networkconnection -> do - liftIO $ C.traceIO "Client successfully accepted!" used <- liftIO MVar.newEmptyMVar liftIO $ MVar.putMVar used False return $ VChan networkconnection used @@ -217,7 +206,6 @@ eval = \case Connect e0 tname e1 e2-> do r <- liftIO DC.newConnection w <- liftIO DC.newConnection - liftIO $ C.traceIO "Client trying to connect" val <- interpret' e0 case val of VInt port -> do @@ -270,26 +258,13 @@ interpretApp _ natrec@(VNewNatRec env f n1 tid ty ez y es) (VInt n) | n > 0 = do let env' = extendEnv n1 (VInt (n-1)) (extendEnv f natrec env) R.local (Data.Bifunctor.first (const env')) (interpret' es) --- interpretApp _ (VSend v@(VChan _ c handle _ _ _)) w = do interpretApp _ (VSend v@(VChan cc usedmvar)) w = do used <- liftIO $ MVar.readMVar usedmvar if used then throw $ VChanIsUsedException $ show v else do (env, (sockets, vchanconnections, activeConnections)) <- ask - - -- This needs to be modified to look for VChans also in subtypes - {- case w of - VChan nc _ _ -> liftIO $ SSem.wait (NCon.ncHandlingIncomingMessage nc) - _ -> return ()-} - - -- liftIO $ NClient.sendValue activeConnections cc w (-1) socketsraw <- liftIO $ MVar.readMVar sockets let port = show $ head $ Map.keys socketsraw liftIO $ NClient.sendValue vchanconnections activeConnections cc w port (-1) - - {-case w of - VChan nc _ _ -> liftIO $ SSem.signal (NCon.ncHandlingIncomingMessage nc) - _ -> return ()-} - -- Disable old VChan liftIO $ disableOldVChan v interpretApp e _ _ = throw $ ApplicationException e From 905e96e8207b171a3182a577d9d0022629a28f87 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 14 Feb 2023 17:36:30 +0100 Subject: [PATCH 150/229] Cleanup and fix of logic bug --- src/Networking/Server.hs | 21 ++------------------- src/ProcessEnvironment.hs | 20 -------------------- testOftenHandoff5.sh | 3 +++ 3 files changed, 5 insertions(+), 39 deletions(-) create mode 100644 testOftenHandoff5.sh diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 691d9d6..2e6b4f1 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -287,21 +287,10 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do mbyUnclean <- DC.readUnreadMessageInterpreter readDC case mbyUnclean of Just unclean -> do - Config.traceNetIO "Preparing value" - uncleanser <- NSerialize.serialize unclean - Config.traceNetIO uncleanser val <- replaceVChanSerial activeCons vchanconsvar unclean - cleanser <- NSerialize.serialize val - Config.traceNetIO cleanser waitUntilContactedNewPeers activeCons val ownport - case val of - VChan nc _ -> do - connectionState <- MVar.readMVar $ ncConnectionState nc - Config.traceNetIO $ show connectionState - _ -> return () msgCount <- DC.unreadMessageStart $ ncRead networkconnection - Config.traceNetIO "Trying to acknowledge message" NClient.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) msgCount) $ -1 return val Nothing -> if count == 0 then do @@ -317,12 +306,7 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do mbyUnclean <- DC.readUnreadMessageInterpreter readDC case mbyUnclean of Just unclean -> do - Config.traceNetIO "Preparing value" - uncleanser <- NSerialize.serialize unclean - Config.traceNetIO uncleanser val <- replaceVChanSerial activeCons vchanconsvar unclean - cleanser <- NSerialize.serialize val - Config.traceNetIO cleanser waitUntilContactedNewPeers activeCons val ownport case val of VChan nc _ -> do @@ -331,10 +315,9 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do _ -> return () msgCount <- DC.unreadMessageStart $ ncRead networkconnection - Config.traceNetIO "Trying to acknowledge message" vchancons <- MVar.readMVar vchanconsvar - let partnerid = Data.Maybe.fromMaybe "" $ ncPartnerUserID networkconnection - let mbypartner = Map.lookup partnerid vchancons + let ownid = Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection + let mbypartner = Map.lookup ownid vchancons case mbypartner of Just partner -> do DC.setUnreadCount (ncRead partner) msgCount diff --git a/src/ProcessEnvironment.hs b/src/ProcessEnvironment.hs index 868b8f0..c07e3eb 100644 --- a/src/ProcessEnvironment.hs +++ b/src/ProcessEnvironment.hs @@ -2,30 +2,10 @@ module ProcessEnvironment where import ProcessEnvironmentTypes -import Syntax as S -import GHC.IO.Handle -import Control.Concurrent.Chan as C import Control.Concurrent.MVar as MVar import Control.Monad.Reader as T -import Data.Set (Set) import Data.Map as Map -import qualified Data.Set as Set -import Kinds (Multiplicity(..)) - -import qualified Data.Maybe - -import Networking.DirectionalConnection -import qualified Networking.NetworkConnection as NCon --- import qualified Networking.Common as NC - -import Network.Socket -import qualified Networking.NetworkConnection as NCon -import qualified Networking.NetworkConnection as NCOn -import qualified Networking.NetworkConnection as Ncon import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC --- import qualified Networking.Common as NC --- | the interpretation monad --- type InterpretM a = T.ReaderT (PEnv, (MVar.MVar (Map.Map Int ServerSocket), MVar.MVar ActiveConnections)) IO a type InterpretM a = T.ReaderT (PEnv, (MVar.MVar (Map.Map Int ServerSocket), VChanConnections, NMC.ActiveConnections)) IO a \ No newline at end of file diff --git a/testOftenHandoff5.sh b/testOftenHandoff5.sh new file mode 100644 index 0000000..5f89635 --- /dev/null +++ b/testOftenHandoff5.sh @@ -0,0 +1,3 @@ +for i in {1..2000}; do + clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff5/handoff.ldgvnw & wait); +done \ No newline at end of file From 2d620e948d4ace671057ae62af517be5c8b06880 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 14 Feb 2023 17:44:27 +0100 Subject: [PATCH 151/229] Removed unnecessary code VI --- src/Networking/Server.hs | 45 +++++++++++++++++----------------- src/ProcessEnvironmentTypes.hs | 8 +----- 2 files changed, 24 insertions(+), 29 deletions(-) diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 2e6b4f1..232557a 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -25,27 +25,28 @@ import Control.Monad import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC import qualified Control.Concurrent.SSem as SSem -import qualified Networking.DirectionalConnection as DC +import qualified Networking.DirectionalConnection as DC +import qualified Data.Bifunctor handleClient :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> Message -> IO () handleClient activeCons mvar clientlist clientsocket hdl ownport message deserialmessages = do let userid = getUserID deserialmessages clientHostaddress <- case snd clientsocket of SockAddrInet _ hostname -> return $ hostaddressTypeToString hostname - _ -> do + _ -> do recievedNetLog message "Error during recieving a networkmessage: only ipv4 is currently supported!" return "" netcons <- MVar.readMVar mvar - case Map.lookup userid netcons of - Just networkcon -> do + case Map.lookup userid netcons of + Just networkcon -> do recievedNetLog message $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " (" ++ ownport ++ ") from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) busy <- SSem.tryWait $ ncHandlingIncomingMessage networkcon case busy of Just num -> do constate <- MVar.readMVar $ ncConnectionState networkcon reply <- case constate of - RedirectRequest _ _ host port _ _ _ -> do + RedirectRequest _ _ host port _ _ _ -> do recievedNetLog message $ "Found redirect request for: " ++ userid recievedNetLog message $ "Send redirect to:" ++ host ++ ":" ++ port SSem.signal $ ncHandlingIncomingMessage networkcon @@ -55,7 +56,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria DC.lockInterpreterReads (ncRead networkcon) DC.writeMessageIfNext (ncRead networkcon) count $ setPartnerHostAddress clientHostaddress val SSem.signal $ ncHandlingIncomingMessage networkcon - recievedNetLog message "Message written to Channel" + recievedNetLog message "Message written to Channel" NC.sendResponse hdl Messages.Okay recievedNetLog message "Sent okay" DC.unlockInterpreterReads (ncRead networkcon) @@ -88,7 +89,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria serial <- NSerialize.serialize deserialmessages recievedNetLog message $ "Error unsupported networkmessage: "++ serial SSem.signal $ ncHandlingIncomingMessage networkcon - NC.sendResponse hdl Messages.Okay + NC.sendResponse hdl Messages.Okay _ -> do recievedNetLog message "Network Connection is in a illegal state!" SSem.signal $ ncHandlingIncomingMessage networkcon @@ -122,7 +123,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria recievedNetLog message $ "Error unsupported networkmessage: "++ serial recievedNetLog message "This is probably a timing issue! Lets resend later" NC.sendResponse hdl Messages.Wait - + recievedNetLog message "Message successfully handled" @@ -136,15 +137,15 @@ setPartnerHostAddress address input = case input of let nv1 = setPartnerHostAddress address v1 in let nv2 = setPartnerHostAddress address v2 in VPair nv1 nv2 - VFunc penv a b -> + VFunc penv a b -> let newpenv = setPartnerHostAddressPEnv address penv in VFunc newpenv a b VDynCast v g -> VDynCast (setPartnerHostAddress address v) g VFuncCast v a b -> VFuncCast (setPartnerHostAddress address v) a b - VRec penv a b c d -> + VRec penv a b c d -> let newpenv = setPartnerHostAddressPEnv address penv in - VRec newpenv a b c d - VNewNatRec penv a b c d e f g -> + VRec newpenv a b c d + VNewNatRec penv a b c d e f g -> let newpenv = setPartnerHostAddressPEnv address penv in VNewNatRec newpenv a b c d e f g VChanSerial r w p o c -> do @@ -173,7 +174,7 @@ contactNewPeers activeCons input ownport = case input of VPair v1 v2 -> do nv1 <- contactNewPeers activeCons v1 ownport nv2 <- contactNewPeers activeCons v2 ownport - return (nv1 || nv2) + return (nv1 || nv2) VFunc penv a b -> do contactNewPeersPEnv activeCons penv ownport VDynCast v g -> do @@ -219,8 +220,8 @@ findFittingClientMaybe clientlist desiredType = do fFCMRaw [] _ = ([], Nothing) fFCMRaw (x:xs) desiredtype = if compare (snd x) desiredtype then (xs, Just $ fst x) else do let nextfFCMRaw = fFCMRaw xs desiredtype - (x:(fst nextfFCMRaw), snd nextfFCMRaw) - + Data.Bifunctor.first (x :) nextfFCMRaw + compare :: (Syntax.Type, Syntax.Type) -> (Syntax.Type, Syntax.Type) -> Bool compare a@(aName, aType) b@(bName, bType) = aName == Syntax.dualof bName && aType == bType @@ -283,7 +284,7 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do where recieveValueInternal :: Int -> VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value recieveValueInternal count vchanconsvar activeCons networkconnection ownport = do - let readDC = ncRead networkconnection + let readDC = ncRead networkconnection mbyUnclean <- DC.readUnreadMessageInterpreter readDC case mbyUnclean of Just unclean -> do @@ -297,19 +298,19 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do msgCount <- DC.countMessages $ ncRead networkconnection NClient.sendNetworkMessage activeCons networkconnection (Messages.RequestValue (Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) msgCount) 0 recieveValueInternal 100 vchanconsvar activeCons networkconnection ownport - else do + else do threadDelay 5000 recieveValueInternal (count-1) vchanconsvar activeCons networkconnection ownport recieveValueEmulated :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value recieveValueEmulated vchanconsvar activeCons networkconnection ownport = do - let readDC = ncRead networkconnection + let readDC = ncRead networkconnection mbyUnclean <- DC.readUnreadMessageInterpreter readDC case mbyUnclean of Just unclean -> do val <- replaceVChanSerial activeCons vchanconsvar unclean waitUntilContactedNewPeers activeCons val ownport case val of - VChan nc _ -> do + VChan nc _ -> do connectionState <- MVar.readMVar $ ncConnectionState nc Config.traceNetIO $ show connectionState _ -> return () @@ -319,12 +320,12 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do let ownid = Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection let mbypartner = Map.lookup ownid vchancons case mbypartner of - Just partner -> do + Just partner -> do DC.setUnreadCount (ncRead partner) msgCount _ -> Config.traceNetIO "Something went wrong when acknowleding value of emulated connection" - + return val - Nothing -> do + Nothing -> do threadDelay 5000 recieveValueEmulated vchanconsvar activeCons networkconnection ownport diff --git a/src/ProcessEnvironmentTypes.hs b/src/ProcessEnvironmentTypes.hs index 5c9ae3f..bd27ee3 100644 --- a/src/ProcessEnvironmentTypes.hs +++ b/src/ProcessEnvironmentTypes.hs @@ -1,10 +1,7 @@ {-# LANGUAGE LambdaCase #-} module ProcessEnvironmentTypes where import Syntax as S -import GHC.IO.Handle -import Control.Concurrent.Chan as C import Control.Concurrent.MVar as MVar -import Control.Monad.Reader as T import Data.Set (Set) import Data.Map as Map import qualified Data.Set as Set @@ -31,9 +28,6 @@ data FuncType = FuncType PEnv String S.Type S.Type instance Show FuncType where show (FuncType _ s t1 t2) = "FuncType " ++ show s ++ " " ++ show t1 ++ " " ++ show t2 --- data NetworkAddress = NetworkAddress {hostname :: String, port :: String} --- deriving (Eq, Show) - type ServerSocket = (MVar.MVar [(String, (Type, Type))], String) type VChanConnections = MVar.MVar (Map.Map String (NCon.NetworkConnection Value)) @@ -47,7 +41,7 @@ data Value | VInt Int | VDouble Double | VString String - | VChan (NCon.NetworkConnection Value) (MVar.MVar Bool) --Maybe a "used" mvar to notify that this vchan should no longer be used + | VChan (NCon.NetworkConnection Value) (MVar.MVar Bool) | VChanSerial ([Value], Int) ([Value], Int) String String (String, String, String) | VSend Value | VPair Value Value -- pair of ids that map to two values From c3f2bbe0631c1b45ab429a812d21277122e6d6e6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 14 Feb 2023 19:37:17 +0100 Subject: [PATCH 152/229] Cleanup and seemingly stable 850 runs; manual interruption --- src/Networking/Client.hs | 14 +++++++------- src/Networking/NetworkConnection.hs | 12 ++++++------ src/Networking/Serialize.hs | 2 +- src/Networking/Server.hs | 14 +++++++------- 4 files changed, 21 insertions(+), 21 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 07fee60..0cbf3f9 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -40,12 +40,12 @@ sendValue vchanconsmvar activeCons networkconnection val ownport resendOnError = valcleaned <- replaceVChan val DC.writeMessage (ncWrite networkconnection) valcleaned messagesCount <- DC.countMessages $ ncWrite networkconnection - tryToSendNetworkMessage activeCons networkconnection hostname port (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection) messagesCount valcleaned) resendOnError + tryToSendNetworkMessage activeCons networkconnection hostname port (Messages.NewValue (ncOwnUserID networkconnection) messagesCount valcleaned) resendOnError Emulated {} -> do vchancons <- MVar.readMVar vchanconsmvar valCleaned <- replaceVChan val DC.writeMessage (ncWrite networkconnection) valCleaned - let ownid = Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection + let ownid = ncOwnUserID networkconnection let mbypartner = Map.lookup ownid vchancons case mbypartner of Just partner -> do @@ -72,7 +72,7 @@ sendNetworkMessage activeCons networkconnection message resendOnError = do tryToSendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> String -> String -> Message -> Int -> IO Bool tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError = do serializedMessage <- NSerialize.serialize message - sendingNetLog serializedMessage $ "Sending message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection) ++ " to: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkconnection) ++ " Over: " ++ hostname ++ ":" ++ port + sendingNetLog serializedMessage $ "Sending message as: " ++ ncOwnUserID networkconnection ++ " to: " ++ ncPartnerUserID networkconnection ++ " Over: " ++ hostname ++ ":" ++ port mbycon <- NC.startConversation activeCons hostname port 10000 10 mbyresponse <- case mbycon of @@ -180,7 +180,7 @@ setRedirectRequests vchanconmvar newhost newport ownport input = case input of VRec penv a b c d -> setRedirectRequestsPEnv vchanconmvar newhost newport ownport penv VNewNatRec penv a b c d e f g -> setRedirectRequestsPEnv vchanconmvar newhost newport ownport penv VChan nc _ -> do - Config.traceNetIO $ "Trying to set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport + Config.traceNetIO $ "Trying to set RedirectRequest for " ++ ncPartnerUserID nc ++ " to " ++ newhost ++ ":" ++ newport SSem.withSem (ncHandlingIncomingMessage nc) (do oldconnectionstate <- MVar.takeMVar $ ncConnectionState nc @@ -192,7 +192,7 @@ setRedirectRequests vchanconmvar newhost newport ownport input = case input of vchanconnections <- MVar.takeMVar vchanconmvar let userid = ncOwnUserID nc - let mbypartner = Map.lookup (Data.Maybe.fromMaybe "" userid) vchanconnections + let mbypartner = Map.lookup userid vchanconnections case mbypartner of Just partner -> do MVar.putMVar (ncConnectionState nc) $ RedirectRequest "" ownport newhost newport partConID ownConID confirmed -- Setting this to 127.0.0.1 is a temporary hack @@ -206,7 +206,7 @@ setRedirectRequests vchanconmvar newhost newport ownport input = case input of MVar.putMVar vchanconmvar vchanconnections Disconnected partConID ownConID confirmed -> Config.traceNetIO "Cannot set RedirectRequest for a disconnected channel" ) - Config.traceNetIO $ "Set RedirectRequest for " ++ (Data.Maybe.fromMaybe "" $ ncPartnerUserID nc) ++ " to " ++ newhost ++ ":" ++ newport + Config.traceNetIO $ "Set RedirectRequest for " ++ ncPartnerUserID nc ++ " to " ++ newhost ++ ":" ++ newport _ -> return () where setRedirectRequestsPEnv :: VChanConnections -> String -> String -> String -> [(String, Value)] -> IO () @@ -274,6 +274,6 @@ sendDisconnect ac mvar = do case connectionState of Connected host port _ _ _ -> if unreadVals >= lengthVals then do - catch (sendNetworkMessage ac con (Messages.Disconnect $ Data.Maybe.fromMaybe "" (ncOwnUserID con)) 0) $ printConErr host port + catch (sendNetworkMessage ac con (Messages.Disconnect $ ncOwnUserID con) 0) $ printConErr host port return True else return False _ -> return True \ No newline at end of file diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index d9fb6f0..50e7249 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -7,7 +7,7 @@ import qualified Data.Map as Map import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.SSem as SSem -data NetworkConnection a = NetworkConnection {ncRead :: DirectionalConnection a, ncWrite :: DirectionalConnection a, ncPartnerUserID :: Maybe String, ncOwnUserID :: Maybe String, ncConnectionState :: MVar.MVar ConnectionState, ncHandlingIncomingMessage :: SSem.SSem} +data NetworkConnection a = NetworkConnection {ncRead :: DirectionalConnection a, ncWrite :: DirectionalConnection a, ncPartnerUserID :: String, ncOwnUserID :: String, ncConnectionState :: MVar.MVar ConnectionState, ncHandlingIncomingMessage :: SSem.SSem} deriving Eq data ConnectionState = Connected {csHostname :: String, csPort :: String, csPartnerConnectionID :: String, csOwnConnectionID :: String, csConfirmedConnection :: Bool} @@ -23,7 +23,7 @@ newNetworkConnection partnerID ownID hostname port partnerConnectionID ownConnec write <- newConnection connectionstate <- MVar.newMVar $ Connected hostname port partnerConnectionID ownConnectionID True incomingMsg <- SSem.new 1 - return $ NetworkConnection read write (Just partnerID) (Just ownID) connectionstate incomingMsg + return $ NetworkConnection read write partnerID ownID connectionstate incomingMsg createNetworkConnection :: ([a], Int) -> ([a], Int) -> String -> String -> (String, String, String) -> IO (NetworkConnection a) @@ -33,7 +33,7 @@ createNetworkConnection (readList, readNew) (writeList, writeNew) partnerID ownI ownConnectionID <- newRandomID connectionstate <- MVar.newMVar $ Connected hostname port partnerConnectionID ownConnectionID False incomingMsg <- SSem.new 1 - return $ NetworkConnection read write (Just partnerID) (Just ownID) connectionstate incomingMsg + return $ NetworkConnection read write partnerID ownID connectionstate incomingMsg newEmulatedConnection :: MVar.MVar (Map.Map String (NetworkConnection a)) -> IO (NetworkConnection a, NetworkConnection a) @@ -51,8 +51,8 @@ newEmulatedConnection mvar = do userid2 <- newRandomID incomingMsg <- SSem.new 1 incomingMsg2 <- SSem.new 1 - let nc1 = NetworkConnection read write (Just userid2) (Just userid) connectionstate incomingMsg - let nc2 = NetworkConnection read2 write2 (Just userid) (Just userid2) connectionstate2 incomingMsg2 + let nc1 = NetworkConnection read write userid2 userid connectionstate incomingMsg + let nc2 = NetworkConnection read2 write2 userid userid2 connectionstate2 incomingMsg2 let ncmap1 = Map.insert userid2 nc1 ncmap let ncmap2 = Map.insert userid nc2 ncmap1 MVar.putMVar mvar ncmap2 @@ -69,7 +69,7 @@ serializeNetworkConnection nc = do Connected address port partnerConnectionID _ _ -> return (address, port, partnerConnectionID) RedirectRequest address port _ _ partnerConnectionID _ _ -> return (address, port, partnerConnectionID) _ -> return ("", "", csPartnerConnectionID constate) - return (readList, readUnread, writeList, writeUnread, Data.Maybe.fromMaybe "" $ ncPartnerUserID nc, Data.Maybe.fromMaybe "" $ ncOwnUserID nc, address, port, partnerConnectionID) + return (readList, readUnread, writeList, writeUnread, ncPartnerUserID nc, ncOwnUserID nc, address, port, partnerConnectionID) changePartnerAddress :: NetworkConnection a -> String -> String -> String -> IO () changePartnerAddress con hostname port partnerConnectionID = do diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index fa18ff3..46c46a3 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -62,7 +62,7 @@ instance Serializable (NCon.NetworkConnection Value) where (readList, readUnread) <- DC.serializeConnection $ NCon.ncRead con (writeList, writeUnread) <- DC.serializeConnection $ NCon.ncWrite con - serializeLabeledEntryMulti "SNetworkConnection" (NCon.ncRead con) $ sNext (NCon.ncWrite con) $ sNext (Data.Maybe.fromMaybe "" $ NCon.ncPartnerUserID con) $ sNext (Data.Maybe.fromMaybe "" $ NCon.ncOwnUserID con) $ sLast constate + serializeLabeledEntryMulti "SNetworkConnection" (NCon.ncRead con) $ sNext (NCon.ncWrite con) $ sNext (NCon.ncPartnerUserID con) $ sNext (NCon.ncOwnUserID con) $ sLast constate instance Serializable (NCon.DirectionalConnection Value) where serialize dcon = do diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 232557a..162cbb9 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -40,7 +40,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria netcons <- MVar.readMVar mvar case Map.lookup userid netcons of Just networkcon -> do - recievedNetLog message $ "Recieved message as: " ++ Data.Maybe.fromMaybe "" (ncOwnUserID networkcon) ++ " (" ++ ownport ++ ") from: " ++ Data.Maybe.fromMaybe "" (ncPartnerUserID networkcon) + recievedNetLog message $ "Recieved message as: " ++ ncOwnUserID networkcon ++ " (" ++ ownport ++ ") from: " ++ ncPartnerUserID networkcon busy <- SSem.tryWait $ ncHandlingIncomingMessage networkcon case busy of Just num -> do @@ -64,7 +64,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Okay mbyval <- DC.readMessageMaybe (NCon.ncWrite networkcon) count - Data.Maybe.maybe (return False) (\val -> NClient.sendNetworkMessage activeCons networkcon (Messages.NewValue (Data.Maybe.fromMaybe "" $ ncOwnUserID networkcon) count val) 0) mbyval + Data.Maybe.maybe (return False) (\val -> NClient.sendNetworkMessage activeCons networkcon (Messages.NewValue (ncOwnUserID networkcon) count val) 0) mbyval return () AcknowledgeValue userid count -> do NC.sendResponse hdl Messages.Okay -- This okay is needed here to fix a race-condition with disconnects being faster than the okay @@ -75,7 +75,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria NCon.changePartnerAddress networkcon clientHostaddress port connectionID SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Okay - NClient.sendNetworkMessage activeCons networkcon (Messages.AcknowledgePartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID networkcon) connectionID) 0 + NClient.sendNetworkMessage activeCons networkcon (Messages.AcknowledgePartnerAddress (ncOwnUserID networkcon) connectionID) 0 return () AcknowledgePartnerAddress userid connectionID -> do conConfirmed <- NCon.confirmConnectionID networkcon connectionID @@ -191,7 +191,7 @@ contactNewPeers activeCons input ownport = case input of Emulated {} -> return True _ -> do if csConfirmedConnection connectionState then return True else do - NClient.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (Data.Maybe.fromMaybe "" $ ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) 0 + NClient.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) 0 return False _ -> return True where @@ -292,11 +292,11 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do waitUntilContactedNewPeers activeCons val ownport msgCount <- DC.unreadMessageStart $ ncRead networkconnection - NClient.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) msgCount) $ -1 + NClient.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (ncOwnUserID networkconnection) msgCount) $ -1 return val Nothing -> if count == 0 then do msgCount <- DC.countMessages $ ncRead networkconnection - NClient.sendNetworkMessage activeCons networkconnection (Messages.RequestValue (Data.Maybe.fromMaybe "" (ncOwnUserID networkconnection)) msgCount) 0 + NClient.sendNetworkMessage activeCons networkconnection (Messages.RequestValue (ncOwnUserID networkconnection) msgCount) 0 recieveValueInternal 100 vchanconsvar activeCons networkconnection ownport else do threadDelay 5000 @@ -317,7 +317,7 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do msgCount <- DC.unreadMessageStart $ ncRead networkconnection vchancons <- MVar.readMVar vchanconsvar - let ownid = Data.Maybe.fromMaybe "" $ ncOwnUserID networkconnection + let ownid = ncOwnUserID networkconnection let mbypartner = Map.lookup ownid vchancons case mbypartner of Just partner -> do From c54cba4e04293c15f539dd64a499d329501e8c9d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 20 Feb 2023 17:48:11 +0100 Subject: [PATCH 153/229] Added new NetworkConnection implementation This is highly experimental. Probably doesn't work yet --- ldgv.cabal | 2 + src/Networking/Buffer.hs | 229 ++++++++++++++++++++++++++++ src/Networking/Client.hs | 20 +-- src/Networking/NetworkBuffer.hs | 141 +++++++++++++++++ src/Networking/NetworkConnection.hs | 34 ++--- src/Networking/Serialize.hs | 24 ++- src/Networking/Server.hs | 34 +++-- src/ProcessEnvironmentTypes.hs | 2 +- src/ValueParsing/ValueGrammar.y | 8 +- 9 files changed, 442 insertions(+), 52 deletions(-) create mode 100644 src/Networking/Buffer.hs create mode 100644 src/Networking/NetworkBuffer.hs diff --git a/ldgv.cabal b/ldgv.cabal index d7f5f92..44d9da2 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -66,10 +66,12 @@ library Examples Interpreter Kinds + Networking.Buffer Networking.Client Networking.Common Networking.DirectionalConnection Networking.Messages + Networking.NetworkBuffer Networking.NetworkConnection Networking.NetworkingMethod.Fast Networking.NetworkingMethod.NetworkingMethodCommon diff --git a/src/Networking/Buffer.hs b/src/Networking/Buffer.hs new file mode 100644 index 0000000..43fa189 --- /dev/null +++ b/src/Networking/Buffer.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE CPP #-} + +module Networking.Buffer where + +{- +Buffer reuses and adapts vast amounts of code from the Control.Concurrent.Chan implementation licenced under: + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.Chan +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : non-portable (concurrency) +-- +-- Unbounded channels. +-- +-- The channels are implemented with @MVar@s and therefore inherit all the +-- caveats that apply to @MVar@s (possibility of races, deadlocks etc). The +-- stm (software transactional memory) library has a more robust implementation +-- of channels called @TChan@s. +-- +----------------------------------------------------------------------------- + +This library (libraries/base) is derived from code from several +sources: + + * Code from the GHC project which is largely (c) The University of + Glasgow, and distributable under a BSD-style license (see below), + + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones + and freely redistributable (but see the full license for + restrictions). + + * Code from the Haskell Foreign Function Interface specification, + which is (c) Manuel M. T. Chakravarty and freely redistributable + (but see the full license for restrictions). + +The full text of these licenses is reproduced below. All of the +licenses are BSD-style or compatible. + +----------------------------------------------------------------------------- + +The Glasgow Haskell Compiler License + +Copyright 2004, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + +----------------------------------------------------------------------------- + +Code derived from the document "Report on the Programming Language +Haskell 98", is distributed under the following license: + + Copyright (c) 2002 Simon Peyton Jones + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Language. + +----------------------------------------------------------------------------- + +Code derived from the document "The Haskell 98 Foreign Function +Interface, An Addendum to the Haskell 98 Report" is distributed under +the following license: + + Copyright (c) 2002 Manuel M. T. Chakravarty + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Foreign Function Interface. + +----------------------------------------------------------------------------- +-} + +import Control.Concurrent.MVar +import Control.Exception +import Control.Monad + + + +#define _UPK_(x) {-# UNPACK #-} !(x) + +data Buffer a = Buffer {bufferReadHead :: _UPK_(MVar (Chain a)), bufferSharedWriteHead :: _UPK_(MVar (Chain a))} + deriving Eq + +type Chain a = MVar (Element a) + +data Element a = Element {elementValue :: a, nextElement :: _UPK_(Chain a)} + deriving Eq + +newBuffer :: IO (Buffer a) +newBuffer = do + element <- newEmptyMVar + readHead <- newMVar element + sharedWriteHead <- newMVar element + return $ Buffer readHead sharedWriteHead + +writeBuffer :: Buffer a -> a -> IO () +writeBuffer buffer@(Buffer readVar sharedWriteVar) value = do + newElement <- newEmptyMVar + mask_ $ do + oldElement <- takeMVar sharedWriteVar + putMVar oldElement $ Element value newElement + putMVar sharedWriteVar newElement + +takeBuffer :: Buffer a -> IO a +takeBuffer buffer@(Buffer readVar sharedWriteVar) = do + readHead <- takeMVar readVar + (Element value bufferStart) <- readMVar readHead + putMVar readVar bufferStart + return value + +tryTakeBuffer :: Buffer a -> IO (Maybe a) +tryTakeBuffer buffer@(Buffer readVar sharedWriteVar) = do + mbyReadHead <- tryTakeMVar readVar + case mbyReadHead of + Just readHead -> do + mbyElement <- tryReadMVar readHead + case mbyElement of + Just (Element value bufferStart) -> do + putMVar readVar bufferStart + return $ Just value + Nothing -> do + putMVar readVar readHead + return Nothing + Nothing -> return Nothing + +readBuffer :: Buffer a -> IO a +readBuffer bufer@(Buffer readVar sharedWriteVar) = do + readHead <- readMVar readVar + (Element value bufferStart) <- readMVar readHead + return value + +tryReadBuffer :: Buffer a -> IO (Maybe a) +tryReadBuffer buffer@(Buffer readVar sharedWriteVar) = do + mbyReadHead <- tryReadMVar readVar + case mbyReadHead of + Just readHead -> do + mbyElement <- tryReadMVar readHead + case mbyElement of + Just (Element value bufferStart) -> do + return $ Just value + Nothing -> return Nothing + Nothing -> return Nothing + +-- Similar to dupChan in the Base package +duplicateBuffer :: Buffer a -> IO (Buffer a) +duplicateBuffer buffer@(Buffer readVar sharedWriteVar) = do + element <- readMVar sharedWriteVar + newReadVar <- newMVar element + return $ Buffer newReadVar sharedWriteVar + +-- Duplicate Buffer along with contents +cloneBuffer :: Buffer a -> IO (Buffer a) +cloneBuffer buffer@(Buffer readVar sharedWriteVar) = do + element <- readMVar readVar + newReadVar <- newMVar element + return $ Buffer newReadVar sharedWriteVar + +consumeBufferToList :: Buffer a -> IO [a] +consumeBufferToList buffer = do + mbyFirstElement <- tryTakeBuffer buffer + case mbyFirstElement of + Just firstElement -> do + listTail <- consumeBufferToList buffer + return $ firstElement:listTail + Nothing -> return [] + +writeBufferToList :: Buffer a -> IO [a] +writeBufferToList buffer = do + clone <- cloneBuffer buffer + consumeBufferToList clone + +getAt :: Buffer a -> Int -> IO a +getAt buffer count = do + clone <- cloneBuffer buffer + -- Take count-1 times + forM_ [1..count] $ \_ -> takeBuffer clone + takeBuffer clone + +tryGetAt :: Buffer a -> Int -> IO (Maybe a) +tryGetAt buffer count = do + clone <- cloneBuffer buffer + tryGetAtInternal clone count + where + tryGetAtInternal :: Buffer a -> Int -> IO (Maybe a) + tryGetAtInternal buffer count | count <= 0 = tryTakeBuffer buffer + | otherwise = do + mbyVal <- tryTakeBuffer buffer + case mbyVal of + Just val -> tryGetAtInternal buffer $ count-1 + Nothing -> return Nothing diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 0cbf3f9..dc51641 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -7,6 +7,7 @@ import ProcessEnvironmentTypes import Networking.Messages import qualified Control.Concurrent.MVar as MVar import qualified Networking.DirectionalConnection as DC +import qualified Networking.NetworkBuffer as NB import qualified Networking.Messages as Messages import qualified Networking.RandomID as RandomID import qualified Data.Map as Map @@ -38,18 +39,17 @@ sendValue vchanconsmvar activeCons networkconnection val ownport resendOnError = Connected hostname port _ _ _ -> do setRedirectRequests vchanconsmvar hostname port ownport val valcleaned <- replaceVChan val - DC.writeMessage (ncWrite networkconnection) valcleaned - messagesCount <- DC.countMessages $ ncWrite networkconnection + messagesCount <- NB.writeNetworkBuffer (ncWrite networkconnection) valcleaned tryToSendNetworkMessage activeCons networkconnection hostname port (Messages.NewValue (ncOwnUserID networkconnection) messagesCount valcleaned) resendOnError Emulated {} -> do vchancons <- MVar.readMVar vchanconsmvar valCleaned <- replaceVChan val - DC.writeMessage (ncWrite networkconnection) valCleaned + NB.writeNetworkBuffer (ncWrite networkconnection) valCleaned let ownid = ncOwnUserID networkconnection let mbypartner = Map.lookup ownid vchancons case mbypartner of Just partner -> do - DC.writeMessage (ncRead partner) valCleaned + NB.writeNetworkBuffer (ncRead partner) valCleaned return True _ -> do Config.traceNetIO "Something went wrong when sending over a emulated connection" @@ -240,8 +240,8 @@ replaceVChan input = case input of newpenv <- replaceVChanPEnv penv return $ VNewNatRec newpenv a b c d e f g VChan nc _-> do - (r, rl, w, wl, pid, oid, h, p, partConID) <- serializeNetworkConnection nc - return $ VChanSerial (r, rl) (w, wl) pid oid (h, p, partConID) + (r, ru, ra, rl, w, wu, wa, wl, pid, oid, h, p, partConID) <- serializeNetworkConnection nc + return $ VChanSerial (r, ru, ra, rl) (w, wu, wa, wl) pid oid (h, p, partConID) _ -> return input where replaceVChanPEnv :: [(String, Value)] -> IO [(String, Value)] @@ -269,10 +269,12 @@ sendDisconnect ac mvar = do sendDisconnectNetworkConnection ac con = do let writeVals = ncWrite con connectionState <- MVar.readMVar $ ncConnectionState con - unreadVals <- DC.unreadMessageStart writeVals - lengthVals <- DC.countMessages writeVals + -- unreadVals <- DC.unreadMessageStart writeVals + -- lengthVals <- DC.countMessages writeVals + allAcknowledged <- NB.isAllAcknowledged writeVals case connectionState of - Connected host port _ _ _ -> if unreadVals >= lengthVals then do + -- Connected host port _ _ _ -> if unreadVals >= lengthVals then do + Connected host port _ _ _ -> if allAcknowledged then do catch (sendNetworkMessage ac con (Messages.Disconnect $ ncOwnUserID con) 0) $ printConErr host port return True else return False diff --git a/src/Networking/NetworkBuffer.hs b/src/Networking/NetworkBuffer.hs new file mode 100644 index 0000000..56f615b --- /dev/null +++ b/src/Networking/NetworkBuffer.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE LambdaCase #-} + +module Networking.NetworkBuffer where + +import Networking.Buffer +import Control.Concurrent.MVar +import Control.Exception +import Data.Functor +import qualified Data.Maybe +import Control.Monad + +data NetworkBuffer a = NetworkBuffer {readNetworkBuffer :: Buffer a, readCounter :: MVar Int, acknowledgeNetworkBuffer :: Buffer a, acknowledgeCounter :: MVar Int, writeCounter :: MVar Int} + deriving Eq + +data NetworkBufferSerial a = NetworkBufferSerial {serialList :: [a], serialReadCounter :: Int, serialAcknowledgeCounter :: Int, serialWriteCounter :: Int} + deriving (Show, Eq) + +type MinimalNetworkBufferSerial a = ([a], Int, Int, Int) + +data NetworkBufferException = InvalidAcknowledgementCount Int Int + +instance Show NetworkBufferException where + show = \case + InvalidAcknowledgementCount found requested -> "NetworkBufferException (InvalidAcknowledgement): Only " ++ show found ++ " values found, out of the requested " ++ show requested ++ " values to acknowledge!" + +instance Exception NetworkBufferException + +newNetworkBuffer :: IO (NetworkBuffer a) +newNetworkBuffer = do + readBuf <- newBuffer + readC <- newMVar 0 + acknowledgeBuf <- cloneBuffer readBuf + acknowledgeC <- newMVar 0 + writeC <- newMVar 0 + return $ NetworkBuffer readBuf readC acknowledgeBuf acknowledgeC writeC + +writeNetworkBuffer :: NetworkBuffer a -> a -> IO Int +writeNetworkBuffer nb value = modifyMVar (writeCounter nb) $ \writeCount -> do + writeBuffer (readNetworkBuffer nb) value + return (writeCount+1, writeCount) + +writeNetworkBufferIfNext :: NetworkBuffer a -> Int -> a -> IO Bool +writeNetworkBufferIfNext nb count value = modifyMVar (writeCounter nb) $ \writeCount -> do + if writeCount == count then do + writeBuffer (readNetworkBuffer nb) value + return (writeCount+1, True) else return (writeCount, False) + +tryTakeAcknowledgeValue :: NetworkBuffer a -> IO (Maybe (a, Int)) +tryTakeAcknowledgeValue nb = modifyMVar (acknowledgeCounter nb) (\acknowledgeCount -> do + mbyAcknowledgeValue <- tryTakeBuffer $ acknowledgeNetworkBuffer nb + case mbyAcknowledgeValue of + Just acknowledgeValue -> return (acknowledgeCount+1, Just (acknowledgeValue, acknowledgeCount+1)) + Nothing -> return (acknowledgeCount, Nothing) + ) + +tryTakeReadValue :: NetworkBuffer a -> IO (Maybe a) +tryTakeReadValue nb = modifyMVar (acknowledgeCounter nb) (\acknowledgeCount -> do + retval <- modifyMVar (readCounter nb) (\readCount -> + if acknowledgeCount > readCount then (do + mbyReadValue <- tryTakeBuffer $ readNetworkBuffer nb + case mbyReadValue of + Just readValue -> return (readCount+1, Just readValue) + Nothing -> return (readCount, Nothing) + ) + else return (readCount, Nothing) + ) + return (acknowledgeCount, retval) + ) + +getRequiredReadValue :: NetworkBuffer a -> IO Int +getRequiredReadValue = readMVar . readCounter + +isAllAcknowledged :: NetworkBuffer a -> IO Bool +isAllAcknowledged nb = do + mbyBuffer <- tryReadBuffer $ acknowledgeNetworkBuffer nb + return $ Data.Maybe.isNothing mbyBuffer + +tryGetReadAt :: NetworkBuffer a -> Int -> IO (Maybe a) +tryGetReadAt nb count = modifyMVar (readCounter nb) (\readCount -> do + ret <- tryGetAt (readNetworkBuffer nb) (count-readCount) + return (readCount, ret) + ) + +tryGetAcknowledgeAt :: NetworkBuffer a -> Int -> IO (Maybe a) +tryGetAcknowledgeAt nb count = modifyMVar (acknowledgeCounter nb) (\ackCount -> do + ret <- tryGetAt (readNetworkBuffer nb) (count-ackCount) + return (ackCount, ret) + ) + + + + +updateAcknowledgements :: NetworkBuffer a -> Int -> IO Bool +updateAcknowledgements nb target = modifyMVar (acknowledgeCounter nb) (updateAcknowledgementsInternal (acknowledgeNetworkBuffer nb) target) + where + updateAcknowledgementsInternal :: Buffer a -> Int -> Int -> IO (Int, Bool) + updateAcknowledgementsInternal ackBuffer targetCount nbCount = do + when (nbCount > targetCount) $ throw $ InvalidAcknowledgementCount nbCount targetCount + if nbCount == targetCount then return (nbCount, True) else do + mbyTakeBuffer <- tryTakeBuffer ackBuffer + case mbyTakeBuffer of + Just takeBuffer -> updateAcknowledgementsInternal ackBuffer targetCount (nbCount+1) + Nothing -> throw $ InvalidAcknowledgementCount nbCount targetCount + +serialize :: NetworkBuffer a -> IO (NetworkBufferSerial a) +serialize nb = modifyMVar (writeCounter nb) (\writeCount -> do + (bufferList, readCount, acknowledgeCount) <- modifyMVar (acknowledgeCounter nb) (\acknowledgeCount -> do + (bufferList, readCount) <- modifyMVar (readCounter nb) (\readCount -> do + bufferList <- writeBufferToList $ readNetworkBuffer nb + return (readCount, (bufferList, readCount)) + ) + return (acknowledgeCount, (bufferList, readCount, acknowledgeCount)) + ) + return (writeCount, NetworkBufferSerial bufferList readCount acknowledgeCount writeCount) + ) + +deserialize :: NetworkBufferSerial a -> IO (NetworkBuffer a) +deserialize nbs@(NetworkBufferSerial list readCount ackCount writeCount) = do + when (ackCount writeBuffer x y >> return x) readB list + ackB <- cloneBuffer readB + ackC <- newMVar ackCount + readC <- newMVar readCount + writeC <- newMVar writeCount + -- Drop the values already acknowledged but not read + forM_ [1..(ackCount-readCount)] $ \_ -> takeBuffer ackB + return $ NetworkBuffer readB readC ackB ackC writeC + +expandSerial :: MinimalNetworkBufferSerial a -> NetworkBufferSerial a +expandSerial (list, readC, ackC, writeC) = NetworkBufferSerial list readC ackC writeC + +compressSerial :: NetworkBufferSerial a -> MinimalNetworkBufferSerial a +compressSerial (NetworkBufferSerial list readC ackC writeC) = (list, readC, ackC, writeC) + +serializeMinimal :: NetworkBuffer a -> IO (MinimalNetworkBufferSerial a) +serializeMinimal nb = serialize nb <&> compressSerial + +deserializeMinimal :: MinimalNetworkBufferSerial a -> IO (NetworkBuffer a) +deserializeMinimal = deserialize . expandSerial \ No newline at end of file diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index 50e7249..7c21d12 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -1,13 +1,13 @@ module Networking.NetworkConnection where import Networking.DirectionalConnection +import Networking.NetworkBuffer import Networking.RandomID -import qualified Data.Maybe import qualified Data.Map as Map import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.SSem as SSem -data NetworkConnection a = NetworkConnection {ncRead :: DirectionalConnection a, ncWrite :: DirectionalConnection a, ncPartnerUserID :: String, ncOwnUserID :: String, ncConnectionState :: MVar.MVar ConnectionState, ncHandlingIncomingMessage :: SSem.SSem} +data NetworkConnection a = NetworkConnection {ncRead :: NetworkBuffer a, ncWrite :: NetworkBuffer a, ncPartnerUserID :: String, ncOwnUserID :: String, ncConnectionState :: MVar.MVar ConnectionState, ncHandlingIncomingMessage :: SSem.SSem} deriving Eq data ConnectionState = Connected {csHostname :: String, csPort :: String, csPartnerConnectionID :: String, csOwnConnectionID :: String, csConfirmedConnection :: Bool} @@ -19,17 +19,17 @@ data ConnectionState = Connected {csHostname :: String, csPort :: String, csPart newNetworkConnection :: String -> String -> String -> String -> String -> String -> IO (NetworkConnection a) newNetworkConnection partnerID ownID hostname port partnerConnectionID ownConnectionID = do - read <- newConnection - write <- newConnection + read <- newNetworkBuffer + write <- newNetworkBuffer connectionstate <- MVar.newMVar $ Connected hostname port partnerConnectionID ownConnectionID True incomingMsg <- SSem.new 1 return $ NetworkConnection read write partnerID ownID connectionstate incomingMsg -createNetworkConnection :: ([a], Int) -> ([a], Int) -> String -> String -> (String, String, String) -> IO (NetworkConnection a) -createNetworkConnection (readList, readNew) (writeList, writeNew) partnerID ownID (hostname, port, partnerConnectionID) = do - read <- createConnection readList readNew - write <- createConnection writeList writeNew +createNetworkConnection :: ([a], Int, Int, Int) -> ([a], Int, Int, Int) -> String -> String -> (String, String, String) -> IO (NetworkConnection a) +createNetworkConnection (readList, readNew, readAck, readListLength) (writeList, writeNew, writeAck, writeListLength) partnerID ownID (hostname, port, partnerConnectionID) = do + read <- deserializeMinimal (readList, readNew, readAck, readListLength) + write <- deserializeMinimal (writeList, writeNew, writeAck, writeListLength) ownConnectionID <- newRandomID connectionstate <- MVar.newMVar $ Connected hostname port partnerConnectionID ownConnectionID False incomingMsg <- SSem.new 1 @@ -39,10 +39,10 @@ createNetworkConnection (readList, readNew) (writeList, writeNew) partnerID ownI newEmulatedConnection :: MVar.MVar (Map.Map String (NetworkConnection a)) -> IO (NetworkConnection a, NetworkConnection a) newEmulatedConnection mvar = do ncmap <- MVar.takeMVar mvar - read <- newConnection - write <- newConnection - read2 <- newConnection - write2 <- newConnection + read <- newNetworkBuffer + write <- newNetworkBuffer + read2 <- newNetworkBuffer + write2 <- newNetworkBuffer connectionid1 <- newRandomID connectionid2 <- newRandomID connectionstate <- MVar.newMVar $ Emulated connectionid2 connectionid1 True @@ -58,18 +58,16 @@ newEmulatedConnection mvar = do MVar.putMVar mvar ncmap2 return (nc1, nc2) - - -serializeNetworkConnection :: NetworkConnection a -> IO ([a], Int, [a], Int, String, String, String, String, String) +serializeNetworkConnection :: NetworkConnection a -> IO ([a], Int, Int, Int, [a], Int, Int, Int, String, String, String, String, String) serializeNetworkConnection nc = do constate <- MVar.readMVar $ ncConnectionState nc - (readList, readUnread) <- serializeConnection $ ncRead nc - (writeList, writeUnread) <- serializeConnection $ ncWrite nc + (readList, readUnread, readUnAck, readListC) <- serializeMinimal $ ncRead nc + (writeList, writeUnread, writeUnAck, writeListC) <- serializeMinimal $ ncWrite nc (address, port, partnerConnectionID) <- case constate of Connected address port partnerConnectionID _ _ -> return (address, port, partnerConnectionID) RedirectRequest address port _ _ partnerConnectionID _ _ -> return (address, port, partnerConnectionID) _ -> return ("", "", csPartnerConnectionID constate) - return (readList, readUnread, writeList, writeUnread, ncPartnerUserID nc, ncOwnUserID nc, address, port, partnerConnectionID) + return (readList, readUnread, readUnAck, readListC, writeList, writeUnread, writeUnAck, writeListC, ncPartnerUserID nc, ncOwnUserID nc, address, port, partnerConnectionID) changePartnerAddress :: NetworkConnection a -> String -> String -> String -> IO () changePartnerAddress con hostname port partnerConnectionID = do diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index 46c46a3..e21ae95 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -12,9 +12,11 @@ import Control.Exception import ProcessEnvironmentTypes import Networking.Messages import qualified Networking.DirectionalConnection as DC +import qualified Networking.NetworkBuffer as NB import qualified Networking.NetworkConnection as NCon import qualified Data.Maybe import qualified Networking.DirectionalConnection as NCon +import qualified Networking.NetworkBuffer as NB newtype SerializationException = UnserializableException String @@ -56,13 +58,16 @@ instance Serializable Message where Disconnect p -> serializeLabeledEntry "NDisconnect" p AcknowledgeDisconnect p -> serializeLabeledEntry "NAcknowledgeDisconnect" p +{- instance Serializable (NCon.NetworkConnection Value) where serialize con = do constate <- MVar.readMVar $ NCon.ncConnectionState con - (readList, readUnread) <- DC.serializeConnection $ NCon.ncRead con - (writeList, writeUnread) <- DC.serializeConnection $ NCon.ncWrite con + -- (readList, readUnread, readUnAck) <- NB.serializeMinimal $ NCon.ncRead con + -- (writeList, writeUnread, writeUnAck) <- NB.serializeMinimal $ NCon.ncWrite con serializeLabeledEntryMulti "SNetworkConnection" (NCon.ncRead con) $ sNext (NCon.ncWrite con) $ sNext (NCon.ncPartnerUserID con) $ sNext (NCon.ncOwnUserID con) $ sLast constate +-} + instance Serializable (NCon.DirectionalConnection Value) where serialize dcon = do @@ -90,7 +95,8 @@ instance Serializable Value where VFuncCast v ft1 ft2 -> serializeLabeledEntryMulti "VFuncCast" v $ sNext ft1 $ sLast ft2 VRec env f x e0 e1 -> serializeLabeledEntryMulti "VRec" env $ sNext f $ sNext x $ sNext e0 $ sLast e1 VNewNatRec env f n tid ty ez x es -> serializeLabeledEntryMulti "VNewNatRec" env $ sNext f $ sNext n $ sNext tid $ sNext ty $ sNext ez $ sNext x $ sLast es - VChan nc _-> serializeLabeledEntry "VChan" nc + -- VChan nc _-> serializeLabeledEntry "VChan" nc + VChan {} -> throw $ UnserializableException "VChan" VChanSerial r w p o c -> serializeLabeledEntryMulti "VChanSerial" r $ sNext w $ sNext p $ sNext o $ sLast c instance Serializable Multiplicity where @@ -222,11 +228,19 @@ instance ((Serializable a, Serializable b) => Serializable (a, b)) where return $ "((" ++ ss ++ ") (" ++ ts ++ "))" instance ((Serializable a, Serializable b, Serializable c) => Serializable (a, b, c)) where - serialize (s, t, v) = do + serialize (s, t, u) = do + ss <- serialize s + ts <- serialize t + us <- serialize u + return $ "((" ++ ss ++ ") (" ++ ts ++ ") (" ++ us ++ "))" + +instance ((Serializable a, Serializable b, Serializable c, Serializable d) => Serializable (a, b, c, d)) where + serialize (s, t, u, v) = do ss <- serialize s ts <- serialize t + us <- serialize u vs <- serialize v - return $ "((" ++ ss ++ ") (" ++ ts ++ ") (" ++ vs ++ "))" + return $ "((" ++ ss ++ ") (" ++ ts ++ ") (" ++ us ++ ") (" ++ vs ++ "))" instance {-# OVERLAPPING #-} Serializable PEnv where serialize arr = serializeLabeledArray "PEnv" arr diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 162cbb9..538c006 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -27,6 +27,7 @@ import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC import qualified Control.Concurrent.SSem as SSem import qualified Networking.DirectionalConnection as DC import qualified Data.Bifunctor +import qualified Networking.NetworkBuffer as NB handleClient :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> Message -> IO () handleClient activeCons mvar clientlist clientsocket hdl ownport message deserialmessages = do @@ -53,22 +54,22 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria NC.sendResponse hdl (Messages.Redirect host port) Connected {} -> case deserialmessages of NewValue userid count val -> do - DC.lockInterpreterReads (ncRead networkcon) - DC.writeMessageIfNext (ncRead networkcon) count $ setPartnerHostAddress clientHostaddress val + -- DC.lockInterpreterReads (ncRead networkcon) + NB.writeNetworkBufferIfNext (ncRead networkcon) count $ setPartnerHostAddress clientHostaddress val SSem.signal $ ncHandlingIncomingMessage networkcon recievedNetLog message "Message written to Channel" NC.sendResponse hdl Messages.Okay recievedNetLog message "Sent okay" - DC.unlockInterpreterReads (ncRead networkcon) + -- DC.unlockInterpreterReads (ncRead networkcon) RequestValue userid count -> do SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Okay - mbyval <- DC.readMessageMaybe (NCon.ncWrite networkcon) count + mbyval <- NB.tryGetAcknowledgeAt (NCon.ncWrite networkcon) count Data.Maybe.maybe (return False) (\val -> NClient.sendNetworkMessage activeCons networkcon (Messages.NewValue (ncOwnUserID networkcon) count val) 0) mbyval return () AcknowledgeValue userid count -> do NC.sendResponse hdl Messages.Okay -- This okay is needed here to fix a race-condition with disconnects being faster than the okay - DC.setUnreadCount (NCon.ncWrite networkcon) count + NB.updateAcknowledgements (NCon.ncWrite networkcon) count SSem.signal $ ncHandlingIncomingMessage networkcon NewPartnerAddress userid port connectionID -> do recievedNetLog message $ "Trying to change the address to: " ++ clientHostaddress ++ ":" ++ port @@ -285,17 +286,19 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do recieveValueInternal :: Int -> VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value recieveValueInternal count vchanconsvar activeCons networkconnection ownport = do let readDC = ncRead networkconnection - mbyUnclean <- DC.readUnreadMessageInterpreter readDC + mbyUnclean <- NB.tryTakeAcknowledgeValue readDC case mbyUnclean of Just unclean -> do - val <- replaceVChanSerial activeCons vchanconsvar unclean + val <- replaceVChanSerial activeCons vchanconsvar $ fst unclean waitUntilContactedNewPeers activeCons val ownport - - msgCount <- DC.unreadMessageStart $ ncRead networkconnection - NClient.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (ncOwnUserID networkconnection) msgCount) $ -1 + + -- Since we currently do both acknowleding and reading in one function we need to iterate both + NB.tryTakeReadValue readDC + -- msgCount <- DC.unreadMessageStart $ ncRead networkconnection + NClient.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (ncOwnUserID networkconnection) $ snd unclean) $ -1 return val Nothing -> if count == 0 then do - msgCount <- DC.countMessages $ ncRead networkconnection + msgCount <- NB.getRequiredReadValue $ ncRead networkconnection NClient.sendNetworkMessage activeCons networkconnection (Messages.RequestValue (ncOwnUserID networkconnection) msgCount) 0 recieveValueInternal 100 vchanconsvar activeCons networkconnection ownport else do @@ -304,10 +307,10 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do recieveValueEmulated :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value recieveValueEmulated vchanconsvar activeCons networkconnection ownport = do let readDC = ncRead networkconnection - mbyUnclean <- DC.readUnreadMessageInterpreter readDC + mbyUnclean <- NB.tryTakeAcknowledgeValue readDC case mbyUnclean of Just unclean -> do - val <- replaceVChanSerial activeCons vchanconsvar unclean + val <- replaceVChanSerial activeCons vchanconsvar $ fst unclean waitUntilContactedNewPeers activeCons val ownport case val of VChan nc _ -> do @@ -315,13 +318,14 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do Config.traceNetIO $ show connectionState _ -> return () - msgCount <- DC.unreadMessageStart $ ncRead networkconnection + -- msgCount <- DC.unreadMessageStart $ ncRead networkconnection vchancons <- MVar.readMVar vchanconsvar let ownid = ncOwnUserID networkconnection let mbypartner = Map.lookup ownid vchancons case mbypartner of Just partner -> do - DC.setUnreadCount (ncRead partner) msgCount + NB.updateAcknowledgements (ncRead partner) $ snd unclean + return () _ -> Config.traceNetIO "Something went wrong when acknowleding value of emulated connection" return val diff --git a/src/ProcessEnvironmentTypes.hs b/src/ProcessEnvironmentTypes.hs index bd27ee3..2206804 100644 --- a/src/ProcessEnvironmentTypes.hs +++ b/src/ProcessEnvironmentTypes.hs @@ -42,7 +42,7 @@ data Value | VDouble Double | VString String | VChan (NCon.NetworkConnection Value) (MVar.MVar Bool) - | VChanSerial ([Value], Int) ([Value], Int) String String (String, String, String) + | VChanSerial ([Value], Int, Int, Int) ([Value], Int, Int, Int) String String (String, String, String) | VSend Value | VPair Value Value -- pair of ids that map to two values | VType S.Type diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index f0d48bc..51fa092 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -191,7 +191,7 @@ Value : vunit { VUnit } | vdouble '(' double ')' {VDouble $3} | vstring '(' String ')' {VString $3 } -- | vchan '(' SValuesArray ')' '(' int ')' '(' SValuesArray ')' '(' int ')' '(' String ')' '(' String ')' '(' String ')' '(' String ')' {VChanSerial $3 $6 $9 $12 $15 $18 $21 $24 } - | vchan '(' NetworkConnection ')' {$3} + -- | vchan '(' NetworkConnection ')' {$3} | vchanserial '(' SArrayIntElement ')' '(' SArrayIntElement ')' '(' String ')' '(' String ')' '(' SStringStringElement3 ')' {VChanSerial $3 $6 $9 $12 $15} | vsend '(' Value ')' {VSend $3} | vpair '(' Value ')' '(' Value ')' {VPair $3 $6} @@ -204,9 +204,9 @@ Value : vunit { VUnit } String : string {trimQuote $1} -NetworkConnection : snetworkconnection '(' DirectionalConnection ')' '(' DirectionalConnection ')' '(' String ')' '(' String ')' '(' ConnectionState ')' {VChanSerial $3 $6 $9 $12 $15} +-- NetworkConnection : snetworkconnection '(' DirectionalConnection ')' '(' DirectionalConnection ')' '(' String ')' '(' String ')' '(' ConnectionState ')' {VChanSerial $3 $6 $9 $12 $15} -DirectionalConnection : sdirectionalconnection '(' SValuesArray ')' '(' int ')' {($3, $6)} +-- DirectionalConnection : sdirectionalconnection '(' SValuesArray ')' '(' int ')' {($3, $6)} ConnectionState : sconnected '(' String ')' '(' String ')' '(' String ')' {($3, $6, $9)} @@ -342,7 +342,7 @@ SValuesElements : Value ',' SValuesElements {$1 : $3} LabelType : slabeltype '{' SStringElements '}' {$3} -SArrayIntElement : '(' '(' SValuesArray ')' '(' int ')' ')' {($3, $6)} +SArrayIntElement : '(' '(' SValuesArray ')' '(' int ')' '(' int ')' '(' int ')' ')' {($3, $6, $9, $12)} SStringStringElement : '(' '(' String ')' '(' String ')' ')' {($3, $6)} From 408704d81ff85dd04df085fd0445d8ce1f806c2a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 21 Feb 2023 14:15:04 +0100 Subject: [PATCH 154/229] Added new implementation of NetworkConnection Still probably buggy --- src/Networking/Buffer.hs | 2 +- src/Networking/Client.hs | 10 +- src/Networking/NetworkBuffer.hs | 153 +++++++++++----------------- src/Networking/NetworkConnection.hs | 17 ++-- src/Networking/Server.hs | 15 ++- src/ProcessEnvironmentTypes.hs | 2 +- src/ValueParsing/ValueGrammar.y | 2 +- 7 files changed, 84 insertions(+), 117 deletions(-) diff --git a/src/Networking/Buffer.hs b/src/Networking/Buffer.hs index 43fa189..c41898d 100644 --- a/src/Networking/Buffer.hs +++ b/src/Networking/Buffer.hs @@ -226,4 +226,4 @@ tryGetAt buffer count = do mbyVal <- tryTakeBuffer buffer case mbyVal of Just val -> tryGetAtInternal buffer $ count-1 - Nothing -> return Nothing + Nothing -> return Nothing \ No newline at end of file diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index dc51641..8149bae 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -39,17 +39,17 @@ sendValue vchanconsmvar activeCons networkconnection val ownport resendOnError = Connected hostname port _ _ _ -> do setRedirectRequests vchanconsmvar hostname port ownport val valcleaned <- replaceVChan val - messagesCount <- NB.writeNetworkBuffer (ncWrite networkconnection) valcleaned + messagesCount <- NB.write (ncWrite networkconnection) valcleaned tryToSendNetworkMessage activeCons networkconnection hostname port (Messages.NewValue (ncOwnUserID networkconnection) messagesCount valcleaned) resendOnError Emulated {} -> do vchancons <- MVar.readMVar vchanconsmvar valCleaned <- replaceVChan val - NB.writeNetworkBuffer (ncWrite networkconnection) valCleaned + NB.write(ncWrite networkconnection) valCleaned let ownid = ncOwnUserID networkconnection let mbypartner = Map.lookup ownid vchancons case mbypartner of Just partner -> do - NB.writeNetworkBuffer (ncRead partner) valCleaned + NB.write (ncRead partner) valCleaned return True _ -> do Config.traceNetIO "Something went wrong when sending over a emulated connection" @@ -240,8 +240,8 @@ replaceVChan input = case input of newpenv <- replaceVChanPEnv penv return $ VNewNatRec newpenv a b c d e f g VChan nc _-> do - (r, ru, ra, rl, w, wu, wa, wl, pid, oid, h, p, partConID) <- serializeNetworkConnection nc - return $ VChanSerial (r, ru, ra, rl) (w, wu, wa, wl) pid oid (h, p, partConID) + (r, ro, rl, w, wo, wl, pid, oid, h, p, partConID) <- serializeNetworkConnection nc + return $ VChanSerial (r, ro, rl) (w, wo, wl) pid oid (h, p, partConID) _ -> return input where replaceVChanPEnv :: [(String, Value)] -> IO [(String, Value)] diff --git a/src/Networking/NetworkBuffer.hs b/src/Networking/NetworkBuffer.hs index 56f615b..75bbc9c 100644 --- a/src/Networking/NetworkBuffer.hs +++ b/src/Networking/NetworkBuffer.hs @@ -8,14 +8,15 @@ import Control.Exception import Data.Functor import qualified Data.Maybe import Control.Monad +import qualified Control.Concurrent.SSem as SSem -data NetworkBuffer a = NetworkBuffer {readNetworkBuffer :: Buffer a, readCounter :: MVar Int, acknowledgeNetworkBuffer :: Buffer a, acknowledgeCounter :: MVar Int, writeCounter :: MVar Int} +data NetworkBuffer a = NetworkBuffer {buffer :: Buffer a, bufferOffset :: MVar Int, bufferAllMessagesLength :: MVar Int, working :: SSem.SSem} deriving Eq -data NetworkBufferSerial a = NetworkBufferSerial {serialList :: [a], serialReadCounter :: Int, serialAcknowledgeCounter :: Int, serialWriteCounter :: Int} +data NetworkBufferSerial a = NetworkBufferSerial {serialList :: [a], serialBufferOffset :: Int, serialBufferAllMessagesLength :: Int} deriving (Show, Eq) -type MinimalNetworkBufferSerial a = ([a], Int, Int, Int) +type MinimalNetworkBufferSerial a = ([a], Int, Int) data NetworkBufferException = InvalidAcknowledgementCount Int Int @@ -27,112 +28,82 @@ instance Exception NetworkBufferException newNetworkBuffer :: IO (NetworkBuffer a) newNetworkBuffer = do - readBuf <- newBuffer - readC <- newMVar 0 - acknowledgeBuf <- cloneBuffer readBuf - acknowledgeC <- newMVar 0 - writeC <- newMVar 0 - return $ NetworkBuffer readBuf readC acknowledgeBuf acknowledgeC writeC - -writeNetworkBuffer :: NetworkBuffer a -> a -> IO Int -writeNetworkBuffer nb value = modifyMVar (writeCounter nb) $ \writeCount -> do - writeBuffer (readNetworkBuffer nb) value - return (writeCount+1, writeCount) - -writeNetworkBufferIfNext :: NetworkBuffer a -> Int -> a -> IO Bool -writeNetworkBufferIfNext nb count value = modifyMVar (writeCounter nb) $ \writeCount -> do - if writeCount == count then do - writeBuffer (readNetworkBuffer nb) value - return (writeCount+1, True) else return (writeCount, False) - -tryTakeAcknowledgeValue :: NetworkBuffer a -> IO (Maybe (a, Int)) -tryTakeAcknowledgeValue nb = modifyMVar (acknowledgeCounter nb) (\acknowledgeCount -> do - mbyAcknowledgeValue <- tryTakeBuffer $ acknowledgeNetworkBuffer nb - case mbyAcknowledgeValue of - Just acknowledgeValue -> return (acknowledgeCount+1, Just (acknowledgeValue, acknowledgeCount+1)) - Nothing -> return (acknowledgeCount, Nothing) + buf <- newBuffer + count <- newMVar 0 + allMessages <- newMVar 0 + work <- SSem.new 1 + return $ NetworkBuffer buf count allMessages work + +write :: NetworkBuffer a -> a -> IO Int +write nb value = SSem.withSem (working nb) $ modifyMVar (bufferAllMessagesLength nb) $ \len -> do + writeBuffer (buffer nb) value + return (len+1, len) + +writeIfNext :: NetworkBuffer a -> Int -> a -> IO Bool +writeIfNext nb index value = SSem.withSem (working nb) $ modifyMVar (bufferAllMessagesLength nb) $ \len -> if index == len then do + writeBuffer (buffer nb) value + return (len+1, True) else return (len, False) + +tryGetAtNB :: NetworkBuffer a -> Int -> IO (Maybe a) +tryGetAtNB nb count = SSem.withSem (working nb) $ do + offset <- readMVar $ bufferOffset nb + tryGetAt (buffer nb) (count-offset) + +tryTake :: NetworkBuffer a -> IO (Maybe (a, Int)) +tryTake nb = SSem.withSem (working nb) $ modifyMVar (bufferOffset nb) (\offset -> do + mbyTakeValue <- tryTakeBuffer (buffer nb) + case mbyTakeValue of + Just value -> return (offset+1, Just (value, offset)) + Nothing -> return (offset, Nothing) ) -tryTakeReadValue :: NetworkBuffer a -> IO (Maybe a) -tryTakeReadValue nb = modifyMVar (acknowledgeCounter nb) (\acknowledgeCount -> do - retval <- modifyMVar (readCounter nb) (\readCount -> - if acknowledgeCount > readCount then (do - mbyReadValue <- tryTakeBuffer $ readNetworkBuffer nb - case mbyReadValue of - Just readValue -> return (readCount+1, Just readValue) - Nothing -> return (readCount, Nothing) - ) - else return (readCount, Nothing) - ) - return (acknowledgeCount, retval) - ) - -getRequiredReadValue :: NetworkBuffer a -> IO Int -getRequiredReadValue = readMVar . readCounter +getNextOffset :: NetworkBuffer a -> IO Int +getNextOffset = readMVar . bufferOffset isAllAcknowledged :: NetworkBuffer a -> IO Bool isAllAcknowledged nb = do - mbyBuffer <- tryReadBuffer $ acknowledgeNetworkBuffer nb + mbyBuffer <- tryReadBuffer $ buffer nb return $ Data.Maybe.isNothing mbyBuffer -tryGetReadAt :: NetworkBuffer a -> Int -> IO (Maybe a) -tryGetReadAt nb count = modifyMVar (readCounter nb) (\readCount -> do - ret <- tryGetAt (readNetworkBuffer nb) (count-readCount) - return (readCount, ret) - ) - -tryGetAcknowledgeAt :: NetworkBuffer a -> Int -> IO (Maybe a) -tryGetAcknowledgeAt nb count = modifyMVar (acknowledgeCounter nb) (\ackCount -> do - ret <- tryGetAt (readNetworkBuffer nb) (count-ackCount) - return (ackCount, ret) +updateAcknowledgements :: NetworkBuffer a -> Int -> IO () +updateAcknowledgements nb target = SSem.withSem (working nb) $ modifyMVar_ (bufferOffset nb) (\offset -> do + updateAcknowledgementsInternal (buffer nb) target offset + return $ target+1 ) - - - - -updateAcknowledgements :: NetworkBuffer a -> Int -> IO Bool -updateAcknowledgements nb target = modifyMVar (acknowledgeCounter nb) (updateAcknowledgementsInternal (acknowledgeNetworkBuffer nb) target) where - updateAcknowledgementsInternal :: Buffer a -> Int -> Int -> IO (Int, Bool) - updateAcknowledgementsInternal ackBuffer targetCount nbCount = do - when (nbCount > targetCount) $ throw $ InvalidAcknowledgementCount nbCount targetCount - if nbCount == targetCount then return (nbCount, True) else do - mbyTakeBuffer <- tryTakeBuffer ackBuffer - case mbyTakeBuffer of - Just takeBuffer -> updateAcknowledgementsInternal ackBuffer targetCount (nbCount+1) - Nothing -> throw $ InvalidAcknowledgementCount nbCount targetCount + updateAcknowledgementsInternal :: Buffer a -> Int -> Int -> IO () + updateAcknowledgementsInternal buf target current | target < current = return () + | otherwise = do + mbyTake <- tryTakeBuffer buf + case mbyTake of + Just _ -> updateAcknowledgementsInternal buf target $ current+1 + Nothing -> throw $ InvalidAcknowledgementCount current target serialize :: NetworkBuffer a -> IO (NetworkBufferSerial a) -serialize nb = modifyMVar (writeCounter nb) (\writeCount -> do - (bufferList, readCount, acknowledgeCount) <- modifyMVar (acknowledgeCounter nb) (\acknowledgeCount -> do - (bufferList, readCount) <- modifyMVar (readCounter nb) (\readCount -> do - bufferList <- writeBufferToList $ readNetworkBuffer nb - return (readCount, (bufferList, readCount)) - ) - return (acknowledgeCount, (bufferList, readCount, acknowledgeCount)) - ) - return (writeCount, NetworkBufferSerial bufferList readCount acknowledgeCount writeCount) - ) +serialize nb = SSem.withSem (working nb) $ do + list <- writeBufferToList $ buffer nb + offset <- readMVar $ bufferOffset nb + allMsgs <- readMVar $ bufferAllMessagesLength nb + return $ NetworkBufferSerial list offset allMsgs + + deserialize :: NetworkBufferSerial a -> IO (NetworkBuffer a) -deserialize nbs@(NetworkBufferSerial list readCount ackCount writeCount) = do - when (ackCount writeBuffer x y >> return x) readB list - ackB <- cloneBuffer readB - ackC <- newMVar ackCount - readC <- newMVar readCount - writeC <- newMVar writeCount - -- Drop the values already acknowledged but not read - forM_ [1..(ackCount-readCount)] $ \_ -> takeBuffer ackB - return $ NetworkBuffer readB readC ackB ackC writeC + foldM_ (\x y -> writeBuffer x y >> return x) buffer list + bOffset <- newMVar offset + bAllMsgs <- newMVar allMsgs + work <- SSem.new 1 + return $ NetworkBuffer buffer bOffset bAllMsgs work expandSerial :: MinimalNetworkBufferSerial a -> NetworkBufferSerial a -expandSerial (list, readC, ackC, writeC) = NetworkBufferSerial list readC ackC writeC +expandSerial (list, readC, ackC) = NetworkBufferSerial list readC ackC compressSerial :: NetworkBufferSerial a -> MinimalNetworkBufferSerial a -compressSerial (NetworkBufferSerial list readC ackC writeC) = (list, readC, ackC, writeC) +compressSerial (NetworkBufferSerial list readC ackC) = (list, readC, ackC) serializeMinimal :: NetworkBuffer a -> IO (MinimalNetworkBufferSerial a) serializeMinimal nb = serialize nb <&> compressSerial diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index 7c21d12..ea273cf 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -1,6 +1,5 @@ module Networking.NetworkConnection where -import Networking.DirectionalConnection import Networking.NetworkBuffer import Networking.RandomID import qualified Data.Map as Map @@ -26,10 +25,10 @@ newNetworkConnection partnerID ownID hostname port partnerConnectionID ownConnec return $ NetworkConnection read write partnerID ownID connectionstate incomingMsg -createNetworkConnection :: ([a], Int, Int, Int) -> ([a], Int, Int, Int) -> String -> String -> (String, String, String) -> IO (NetworkConnection a) -createNetworkConnection (readList, readNew, readAck, readListLength) (writeList, writeNew, writeAck, writeListLength) partnerID ownID (hostname, port, partnerConnectionID) = do - read <- deserializeMinimal (readList, readNew, readAck, readListLength) - write <- deserializeMinimal (writeList, writeNew, writeAck, writeListLength) +createNetworkConnection :: ([a], Int, Int) -> ([a], Int, Int) -> String -> String -> (String, String, String) -> IO (NetworkConnection a) +createNetworkConnection (readList, readOffset, readLength) (writeList, writeOffset, writeLength) partnerID ownID (hostname, port, partnerConnectionID) = do + read <- deserializeMinimal (readList, readOffset, readLength) + write <- deserializeMinimal (writeList, writeOffset, writeLength) ownConnectionID <- newRandomID connectionstate <- MVar.newMVar $ Connected hostname port partnerConnectionID ownConnectionID False incomingMsg <- SSem.new 1 @@ -58,16 +57,16 @@ newEmulatedConnection mvar = do MVar.putMVar mvar ncmap2 return (nc1, nc2) -serializeNetworkConnection :: NetworkConnection a -> IO ([a], Int, Int, Int, [a], Int, Int, Int, String, String, String, String, String) +serializeNetworkConnection :: NetworkConnection a -> IO ([a], Int, Int, [a], Int, Int, String, String, String, String, String) serializeNetworkConnection nc = do constate <- MVar.readMVar $ ncConnectionState nc - (readList, readUnread, readUnAck, readListC) <- serializeMinimal $ ncRead nc - (writeList, writeUnread, writeUnAck, writeListC) <- serializeMinimal $ ncWrite nc + (readList, readOffset, readLength) <- serializeMinimal $ ncRead nc + (writeList, writeOffset, writeLength) <- serializeMinimal $ ncWrite nc (address, port, partnerConnectionID) <- case constate of Connected address port partnerConnectionID _ _ -> return (address, port, partnerConnectionID) RedirectRequest address port _ _ partnerConnectionID _ _ -> return (address, port, partnerConnectionID) _ -> return ("", "", csPartnerConnectionID constate) - return (readList, readUnread, readUnAck, readListC, writeList, writeUnread, writeUnAck, writeListC, ncPartnerUserID nc, ncOwnUserID nc, address, port, partnerConnectionID) + return (readList, readOffset, readLength, writeList, writeOffset, writeLength, ncPartnerUserID nc, ncOwnUserID nc, address, port, partnerConnectionID) changePartnerAddress :: NetworkConnection a -> String -> String -> String -> IO () changePartnerAddress con hostname port partnerConnectionID = do diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 538c006..ee6c1cf 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -55,16 +55,16 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria Connected {} -> case deserialmessages of NewValue userid count val -> do -- DC.lockInterpreterReads (ncRead networkcon) - NB.writeNetworkBufferIfNext (ncRead networkcon) count $ setPartnerHostAddress clientHostaddress val + success <- NB.writeIfNext (ncRead networkcon) count $ setPartnerHostAddress clientHostaddress val SSem.signal $ ncHandlingIncomingMessage networkcon - recievedNetLog message "Message written to Channel" + if success then recievedNetLog message "Message written to Channel" else recievedNetLog message "Message not correct" NC.sendResponse hdl Messages.Okay recievedNetLog message "Sent okay" -- DC.unlockInterpreterReads (ncRead networkcon) RequestValue userid count -> do SSem.signal $ ncHandlingIncomingMessage networkcon NC.sendResponse hdl Messages.Okay - mbyval <- NB.tryGetAcknowledgeAt (NCon.ncWrite networkcon) count + mbyval <- NB.tryGetAtNB (NCon.ncWrite networkcon) count Data.Maybe.maybe (return False) (\val -> NClient.sendNetworkMessage activeCons networkcon (Messages.NewValue (ncOwnUserID networkcon) count val) 0) mbyval return () AcknowledgeValue userid count -> do @@ -286,19 +286,16 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do recieveValueInternal :: Int -> VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value recieveValueInternal count vchanconsvar activeCons networkconnection ownport = do let readDC = ncRead networkconnection - mbyUnclean <- NB.tryTakeAcknowledgeValue readDC + mbyUnclean <- NB.tryTake readDC case mbyUnclean of Just unclean -> do val <- replaceVChanSerial activeCons vchanconsvar $ fst unclean waitUntilContactedNewPeers activeCons val ownport - - -- Since we currently do both acknowleding and reading in one function we need to iterate both - NB.tryTakeReadValue readDC -- msgCount <- DC.unreadMessageStart $ ncRead networkconnection NClient.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (ncOwnUserID networkconnection) $ snd unclean) $ -1 return val Nothing -> if count == 0 then do - msgCount <- NB.getRequiredReadValue $ ncRead networkconnection + msgCount <- NB.getNextOffset $ ncRead networkconnection NClient.sendNetworkMessage activeCons networkconnection (Messages.RequestValue (ncOwnUserID networkconnection) msgCount) 0 recieveValueInternal 100 vchanconsvar activeCons networkconnection ownport else do @@ -307,7 +304,7 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do recieveValueEmulated :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value recieveValueEmulated vchanconsvar activeCons networkconnection ownport = do let readDC = ncRead networkconnection - mbyUnclean <- NB.tryTakeAcknowledgeValue readDC + mbyUnclean <- NB.tryTake readDC case mbyUnclean of Just unclean -> do val <- replaceVChanSerial activeCons vchanconsvar $ fst unclean diff --git a/src/ProcessEnvironmentTypes.hs b/src/ProcessEnvironmentTypes.hs index 2206804..6d65ad2 100644 --- a/src/ProcessEnvironmentTypes.hs +++ b/src/ProcessEnvironmentTypes.hs @@ -42,7 +42,7 @@ data Value | VDouble Double | VString String | VChan (NCon.NetworkConnection Value) (MVar.MVar Bool) - | VChanSerial ([Value], Int, Int, Int) ([Value], Int, Int, Int) String String (String, String, String) + | VChanSerial ([Value], Int, Int) ([Value], Int, Int) String String (String, String, String) | VSend Value | VPair Value Value -- pair of ids that map to two values | VType S.Type diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 51fa092..3e3e5a6 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -342,7 +342,7 @@ SValuesElements : Value ',' SValuesElements {$1 : $3} LabelType : slabeltype '{' SStringElements '}' {$3} -SArrayIntElement : '(' '(' SValuesArray ')' '(' int ')' '(' int ')' '(' int ')' ')' {($3, $6, $9, $12)} +SArrayIntElement : '(' '(' SValuesArray ')' '(' int ')' '(' int ')' ')' {($3, $6, $9)} SStringStringElement : '(' '(' String ')' '(' String ')' ')' {($3, $6)} From 589bdb64067338bc29797e6de70d2f97359ef976 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 21 Feb 2023 14:43:22 +0100 Subject: [PATCH 155/229] Fixed "stack test" --- src/Networking/Server.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index ee6c1cf..a011f54 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -321,7 +321,7 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do let mbypartner = Map.lookup ownid vchancons case mbypartner of Just partner -> do - NB.updateAcknowledgements (ncRead partner) $ snd unclean + NB.updateAcknowledgements (ncWrite partner) $ snd unclean return () _ -> Config.traceNetIO "Something went wrong when acknowleding value of emulated connection" From 69315b6396141f73d25cf672cf515d6f698e657a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 21 Feb 2023 15:30:47 +0100 Subject: [PATCH 156/229] Fixed a logic bug in NetworkBuffer --- src/Networking/NetworkBuffer.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Networking/NetworkBuffer.hs b/src/Networking/NetworkBuffer.hs index 75bbc9c..16fac1e 100644 --- a/src/Networking/NetworkBuffer.hs +++ b/src/Networking/NetworkBuffer.hs @@ -19,10 +19,12 @@ data NetworkBufferSerial a = NetworkBufferSerial {serialList :: [a], serialBuffe type MinimalNetworkBufferSerial a = ([a], Int, Int) data NetworkBufferException = InvalidAcknowledgementCount Int Int + | InvalidNetworkBufferState Int Int Int instance Show NetworkBufferException where show = \case InvalidAcknowledgementCount found requested -> "NetworkBufferException (InvalidAcknowledgement): Only " ++ show found ++ " values found, out of the requested " ++ show requested ++ " values to acknowledge!" + InvalidNetworkBufferState len offset allMsgs -> "NetworkBufferException (InvalidNetworkBufferState): List Length " ++ show len ++ " + " ++ show offset ++ " need to equal " ++ show allMsgs ++ "!" instance Exception NetworkBufferException @@ -90,7 +92,7 @@ serialize nb = SSem.withSem (working nb) $ do deserialize :: NetworkBufferSerial a -> IO (NetworkBuffer a) deserialize nbs@(NetworkBufferSerial list offset allMsgs ) = do - when (offset writeBuffer x y >> return x) buffer list From f980d0f21e72c7fc55a254e6d6103c8cd3697cb2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 21 Feb 2023 17:17:21 +0100 Subject: [PATCH 157/229] Every test completes now Still probably unstable --- src/Networking/Client.hs | 3 +++ src/Networking/Server.hs | 50 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 53 insertions(+) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 8149bae..92f58c3 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -271,6 +271,9 @@ sendDisconnect ac mvar = do connectionState <- MVar.readMVar $ ncConnectionState con -- unreadVals <- DC.unreadMessageStart writeVals -- lengthVals <- DC.countMessages writeVals + Config.traceNetIO "Checking if everything is acknowledged" + NB.serialize writeVals >>= Config.traceNetIO . show + NB.isAllAcknowledged writeVals >>= Config.traceNetIO . show allAcknowledged <- NB.isAllAcknowledged writeVals case connectionState of -- Connected host port _ _ _ -> if unreadVals >= lengthVals then do diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index a011f54..a2ae3e3 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -69,6 +69,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria return () AcknowledgeValue userid count -> do NC.sendResponse hdl Messages.Okay -- This okay is needed here to fix a race-condition with disconnects being faster than the okay + NB.serialize (ncWrite networkcon) >>= \x -> Config.traceNetIO $ "Online before acknowlegment: " ++ show x NB.updateAcknowledgements (NCon.ncWrite networkcon) count SSem.signal $ ncHandlingIncomingMessage networkcon NewPartnerAddress userid port connectionID -> do @@ -276,6 +277,49 @@ replaceVChanSerial activeCons mvar input = case input of rest <- replaceVChanSerialPEnv activeCons mvar xs return $ (fst x, newval):rest +recieveValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value +recieveValue vchanconsvar activeCons networkconnection ownport = do + recieveValueInternal 0 vchanconsvar activeCons networkconnection ownport + where + recieveValueInternal :: Int -> VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value + recieveValueInternal count vchanconsvar activeCons networkconnection ownport = do + let readDC = ncRead networkconnection + mbyUnclean <- NB.tryTake readDC + case mbyUnclean of + Just unclean -> do + val <- replaceVChanSerial activeCons vchanconsvar $ fst unclean + waitUntilContactedNewPeers activeCons val ownport + -- msgCount <- DC.unreadMessageStart $ ncRead networkconnection + connectionState <- MVar.readMVar $ ncConnectionState networkconnection + case connectionState of + Connected {} -> NClient.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (ncOwnUserID networkconnection) $ snd unclean) $ -1 + Emulated {} -> do + vchancons <- MVar.readMVar vchanconsvar + let ownid = ncOwnUserID networkconnection + let mbypartner = Map.lookup ownid vchancons + case mbypartner of + Just partner -> do + NB.serialize (ncWrite partner) >>= \x -> Config.traceNetIO $ "Emulated "++ show unclean ++ " before acknowlegment: " ++ show x + NB.updateAcknowledgements (ncWrite partner) $ snd unclean + return True + _ -> Config.traceNetIO "Something went wrong when acknowleding value of emulated connection" >> return True + _ -> return True + + return val + Nothing -> if count == 0 then do + msgCount <- NB.getNextOffset $ ncRead networkconnection + connectionState <- MVar.readMVar $ ncConnectionState networkconnection + case connectionState of + Connected {} -> NClient.sendNetworkMessage activeCons networkconnection (Messages.RequestValue (ncOwnUserID networkconnection) msgCount) 0 + _ -> return True + recieveValueInternal 100 vchanconsvar activeCons networkconnection ownport + else do + threadDelay 5000 + recieveValueInternal (count-1) vchanconsvar activeCons networkconnection ownport + + +{- + recieveValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value recieveValue vchanconsvar activeCons networkconnection ownport = do connectionState <- MVar.readMVar $ ncConnectionState networkconnection @@ -321,6 +365,7 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do let mbypartner = Map.lookup ownid vchancons case mbypartner of Just partner -> do + NB.serialize (ncWrite partner) >>= \x -> Config.traceNetIO $ "Emulated "++ show unclean ++ " before acknowlegment: " ++ show x NB.updateAcknowledgements (ncWrite partner) $ snd unclean return () _ -> Config.traceNetIO "Something went wrong when acknowleding value of emulated connection" @@ -330,3 +375,8 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do threadDelay 5000 recieveValueEmulated vchanconsvar activeCons networkconnection ownport + + + + +-} \ No newline at end of file From 387c4135591f8ce8ff8961b87cc6d81fc451057f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 21 Feb 2023 17:25:20 +0100 Subject: [PATCH 158/229] Fixed horrendously slow speeds --- src/Networking/Server.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index a2ae3e3..9feee9b 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -69,7 +69,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria return () AcknowledgeValue userid count -> do NC.sendResponse hdl Messages.Okay -- This okay is needed here to fix a race-condition with disconnects being faster than the okay - NB.serialize (ncWrite networkcon) >>= \x -> Config.traceNetIO $ "Online before acknowlegment: " ++ show x + -- NB.serialize (ncWrite networkcon) >>= \x -> Config.traceNetIO $ "Online before acknowlegment: " ++ show x NB.updateAcknowledgements (NCon.ncWrite networkcon) count SSem.signal $ ncHandlingIncomingMessage networkcon NewPartnerAddress userid port connectionID -> do @@ -299,7 +299,7 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do let mbypartner = Map.lookup ownid vchancons case mbypartner of Just partner -> do - NB.serialize (ncWrite partner) >>= \x -> Config.traceNetIO $ "Emulated "++ show unclean ++ " before acknowlegment: " ++ show x + -- NB.serialize (ncWrite partner) >>= \x -> Config.traceNetIO $ "Emulated "++ show unclean ++ " before acknowlegment: " ++ show x NB.updateAcknowledgements (ncWrite partner) $ snd unclean return True _ -> Config.traceNetIO "Something went wrong when acknowleding value of emulated connection" >> return True From eb9e12ef27abad4f69c9a8679a0147f6f3f637d2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 21 Feb 2023 17:31:03 +0100 Subject: [PATCH 159/229] Update Client.hs --- src/Networking/Client.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 92f58c3..05a483f 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -271,9 +271,9 @@ sendDisconnect ac mvar = do connectionState <- MVar.readMVar $ ncConnectionState con -- unreadVals <- DC.unreadMessageStart writeVals -- lengthVals <- DC.countMessages writeVals - Config.traceNetIO "Checking if everything is acknowledged" - NB.serialize writeVals >>= Config.traceNetIO . show - NB.isAllAcknowledged writeVals >>= Config.traceNetIO . show + -- Config.traceNetIO "Checking if everything is acknowledged" + -- NB.serialize writeVals >>= Config.traceNetIO . show + -- NB.isAllAcknowledged writeVals >>= Config.traceNetIO . show allAcknowledged <- NB.isAllAcknowledged writeVals case connectionState of -- Connected host port _ _ _ -> if unreadVals >= lengthVals then do From f62d7ef15cd90102091e2504fae8eb9e862ba669 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 22 Feb 2023 14:12:51 +0100 Subject: [PATCH 160/229] Removed DirectionalConnection --- ldgv.cabal | 3 +- src/Interpreter.hs | 3 - src/Networking/Client.hs | 1 - src/Networking/DirectionalConnection.hs | 126 ------------------------ src/Networking/Serialize.hs | 11 --- src/Networking/Server.hs | 67 +------------ 6 files changed, 2 insertions(+), 209 deletions(-) delete mode 100644 src/Networking/DirectionalConnection.hs diff --git a/ldgv.cabal b/ldgv.cabal index 44d9da2..1aeca8c 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.35.0. +-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack @@ -69,7 +69,6 @@ library Networking.Buffer Networking.Client Networking.Common - Networking.DirectionalConnection Networking.Messages Networking.NetworkBuffer Networking.NetworkConnection diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 2d73f2c..79922dd 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -28,7 +28,6 @@ import qualified Networking.Server as NS import Control.Concurrent -import qualified Networking.DirectionalConnection as DC import qualified Networking.NetworkConnection as NCon import ProcessEnvironmentTypes import qualified Data.Bifunctor @@ -204,8 +203,6 @@ eval = \case _ -> throw $ NotAnExpectedValueException "VInt" val Connect e0 tname e1 e2-> do - r <- liftIO DC.newConnection - w <- liftIO DC.newConnection val <- interpret' e0 case val of VInt port -> do diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 05a483f..abbaa12 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -6,7 +6,6 @@ import qualified Config import ProcessEnvironmentTypes import Networking.Messages import qualified Control.Concurrent.MVar as MVar -import qualified Networking.DirectionalConnection as DC import qualified Networking.NetworkBuffer as NB import qualified Networking.Messages as Messages import qualified Networking.RandomID as RandomID diff --git a/src/Networking/DirectionalConnection.hs b/src/Networking/DirectionalConnection.hs deleted file mode 100644 index ccb0f25..0000000 --- a/src/Networking/DirectionalConnection.hs +++ /dev/null @@ -1,126 +0,0 @@ -module Networking.DirectionalConnection where - -import Control.Concurrent.MVar -import Control.Concurrent -import qualified Control.Concurrent.SSem as SSem -import Control.Monad - -data DirectionalConnection a = DirectionalConnection { messages :: MVar [a], messagesUnreadStart :: MVar Int, messagesCount :: MVar Int, readLock :: SSem.SSem} - deriving Eq - -newConnection :: IO (DirectionalConnection a) -newConnection = do - messages <- newEmptyMVar - putMVar messages [] - messagesUnreadStart <- newEmptyMVar - putMVar messagesUnreadStart 0 - messagesCount <- newEmptyMVar - putMVar messagesCount 0 - readLock <- SSem.new 1 - return $ DirectionalConnection messages messagesUnreadStart messagesCount readLock - - -createConnection :: [a] -> Int -> IO (DirectionalConnection a) -createConnection messages unreadStart = do - msg <- newEmptyMVar - putMVar msg messages - messagesUnreadStart <- newEmptyMVar - putMVar messagesUnreadStart unreadStart - messagesCount <- newEmptyMVar - putMVar messagesCount $ length messages - readLock <- SSem.new 1 - return $ DirectionalConnection msg messagesUnreadStart messagesCount readLock - - -writeMessage :: DirectionalConnection a -> a -> IO () -writeMessage connection message = do - modifyMVar_ (messagesCount connection) (\c -> do - modifyMVar_ (messages connection) (\m -> return $ m ++ [message]) - return $ c + 1 - ) - -writeMessageIfNext :: DirectionalConnection a -> Int -> a -> IO Bool -writeMessageIfNext connection count message = do - modifyMVar (messagesCount connection) (\c -> - if count == c + 1 then do - modifyMVar_ (messages connection) (\m -> return $ m ++ [message]) - return (c + 1, True) - else - return (c, False) - ) - - --- This relies on the message array giving having the same first entrys as the internal messages -syncMessages :: DirectionalConnection a -> [a] -> IO () -syncMessages connection msgs = do - mymessagesCount <- takeMVar $ messagesCount connection - mymessages <- takeMVar $ messages connection - if length mymessages < length msgs then do - putMVar (messages connection) msgs - putMVar (messagesCount connection) $ length msgs - else do - putMVar (messages connection) mymessages - putMVar (messagesCount connection) mymessagesCount - --- Gives all outMessages until this point -allMessages :: DirectionalConnection a -> IO [a] -allMessages connection = readMVar (messages connection) - -readUnreadMessageMaybe :: DirectionalConnection a -> IO (Maybe a) -readUnreadMessageMaybe connection = modifyMVar (messagesUnreadStart connection) (\i -> do - messagesBind <- allMessages connection - if length messagesBind <= i then return (i, Nothing) else return (i+1, Just (messagesBind!!i)) - ) - --- Basically only used for the internal tests at this point -readUnreadMessage :: DirectionalConnection a -> IO a -readUnreadMessage connection = do - maybeval <- readUnreadMessageMaybe connection - case maybeval of - Nothing -> do - threadDelay 5000 - readUnreadMessage connection - Just val -> return val - -readMessageMaybe :: DirectionalConnection a -> Int -> IO (Maybe a) -readMessageMaybe connection index = do - msgList <- readMVar $ messages connection - if length msgList > index then return $ Just $ msgList !! index else return Nothing - -setUnreadCount :: DirectionalConnection a -> Int -> IO () -setUnreadCount connection index = do - msgLength <- readMVar $ messagesCount connection - when (msgLength >= index) $ do - unreadLength <- takeMVar $ messagesUnreadStart connection - if index > unreadLength then putMVar (messagesUnreadStart connection) index else putMVar (messagesUnreadStart connection) unreadLength - -readUnreadMessageInterpreter :: DirectionalConnection a -> IO (Maybe a) -readUnreadMessageInterpreter connection = SSem.withSem (readLock connection) $ readUnreadMessageMaybe connection - -serializeConnection :: DirectionalConnection a -> IO ([a], Int) -serializeConnection connection = do - messageList <- allMessages connection - messageUnread <- readMVar $ messagesUnreadStart connection - return (messageList, messageUnread) - -countMessages :: DirectionalConnection a -> IO Int -countMessages connection = readMVar $ messagesCount connection - -unreadMessageStart :: DirectionalConnection a -> IO Int -unreadMessageStart connection = readMVar $ messagesUnreadStart connection - -lockInterpreterReads :: DirectionalConnection a -> IO () -lockInterpreterReads connection = SSem.wait (readLock connection) - -unlockInterpreterReads :: DirectionalConnection a -> IO () -unlockInterpreterReads connection = SSem.signal (readLock connection) - -test = do - mycon <- newConnection - writeMessage mycon "a" - writeMessage mycon "b" - allMessages mycon >>= print - readUnreadMessage mycon >>= print - allMessages mycon >>= print - readUnreadMessage mycon >>= print - readUnreadMessage mycon >>= print \ No newline at end of file diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index e21ae95..92a9d5c 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -11,13 +11,9 @@ import Data.Set import Control.Exception import ProcessEnvironmentTypes import Networking.Messages -import qualified Networking.DirectionalConnection as DC import qualified Networking.NetworkBuffer as NB import qualified Networking.NetworkConnection as NCon import qualified Data.Maybe -import qualified Networking.DirectionalConnection as NCon -import qualified Networking.NetworkBuffer as NB - newtype SerializationException = UnserializableException String deriving Eq @@ -68,13 +64,6 @@ instance Serializable (NCon.NetworkConnection Value) where serializeLabeledEntryMulti "SNetworkConnection" (NCon.ncRead con) $ sNext (NCon.ncWrite con) $ sNext (NCon.ncPartnerUserID con) $ sNext (NCon.ncOwnUserID con) $ sLast constate -} - -instance Serializable (NCon.DirectionalConnection Value) where - serialize dcon = do - (msg, msgUnread) <- DC.serializeConnection dcon - - serializeLabeledEntryMulti "SDirectionalConnection" msg $ sLast msgUnread - instance Serializable NCon.ConnectionState where serialize = \case NCon.Connected hostname port partnerConnectionID _ _ -> serializeLabeledEntryMulti "SConnected" hostname $ sNext port $ sLast partnerConnectionID diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 9feee9b..0fc58ac 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -25,7 +25,6 @@ import Control.Monad import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC import qualified Control.Concurrent.SSem as SSem -import qualified Networking.DirectionalConnection as DC import qualified Data.Bifunctor import qualified Networking.NetworkBuffer as NB @@ -315,68 +314,4 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do recieveValueInternal 100 vchanconsvar activeCons networkconnection ownport else do threadDelay 5000 - recieveValueInternal (count-1) vchanconsvar activeCons networkconnection ownport - - -{- - -recieveValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value -recieveValue vchanconsvar activeCons networkconnection ownport = do - connectionState <- MVar.readMVar $ ncConnectionState networkconnection - case connectionState of - Emulated {} -> recieveValueEmulated vchanconsvar activeCons networkconnection ownport - _ -> recieveValueInternal 0 vchanconsvar activeCons networkconnection ownport - where - recieveValueInternal :: Int -> VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value - recieveValueInternal count vchanconsvar activeCons networkconnection ownport = do - let readDC = ncRead networkconnection - mbyUnclean <- NB.tryTake readDC - case mbyUnclean of - Just unclean -> do - val <- replaceVChanSerial activeCons vchanconsvar $ fst unclean - waitUntilContactedNewPeers activeCons val ownport - -- msgCount <- DC.unreadMessageStart $ ncRead networkconnection - NClient.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (ncOwnUserID networkconnection) $ snd unclean) $ -1 - return val - Nothing -> if count == 0 then do - msgCount <- NB.getNextOffset $ ncRead networkconnection - NClient.sendNetworkMessage activeCons networkconnection (Messages.RequestValue (ncOwnUserID networkconnection) msgCount) 0 - recieveValueInternal 100 vchanconsvar activeCons networkconnection ownport - else do - threadDelay 5000 - recieveValueInternal (count-1) vchanconsvar activeCons networkconnection ownport - recieveValueEmulated :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value - recieveValueEmulated vchanconsvar activeCons networkconnection ownport = do - let readDC = ncRead networkconnection - mbyUnclean <- NB.tryTake readDC - case mbyUnclean of - Just unclean -> do - val <- replaceVChanSerial activeCons vchanconsvar $ fst unclean - waitUntilContactedNewPeers activeCons val ownport - case val of - VChan nc _ -> do - connectionState <- MVar.readMVar $ ncConnectionState nc - Config.traceNetIO $ show connectionState - _ -> return () - - -- msgCount <- DC.unreadMessageStart $ ncRead networkconnection - vchancons <- MVar.readMVar vchanconsvar - let ownid = ncOwnUserID networkconnection - let mbypartner = Map.lookup ownid vchancons - case mbypartner of - Just partner -> do - NB.serialize (ncWrite partner) >>= \x -> Config.traceNetIO $ "Emulated "++ show unclean ++ " before acknowlegment: " ++ show x - NB.updateAcknowledgements (ncWrite partner) $ snd unclean - return () - _ -> Config.traceNetIO "Something went wrong when acknowleding value of emulated connection" - - return val - Nothing -> do - threadDelay 5000 - recieveValueEmulated vchanconsvar activeCons networkconnection ownport - - - - - --} \ No newline at end of file + recieveValueInternal (count-1) vchanconsvar activeCons networkconnection ownport \ No newline at end of file From 423d8163b042a422fd9e9115cb403a1c64c8023e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 22 Feb 2023 14:17:58 +0100 Subject: [PATCH 161/229] Clearer name for the partner in handleClient --- src/Networking/Server.hs | 50 ++++++++++++++++++++-------------------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 0fc58ac..651b948 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -39,66 +39,66 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria netcons <- MVar.readMVar mvar case Map.lookup userid netcons of - Just networkcon -> do - recievedNetLog message $ "Recieved message as: " ++ ncOwnUserID networkcon ++ " (" ++ ownport ++ ") from: " ++ ncPartnerUserID networkcon - busy <- SSem.tryWait $ ncHandlingIncomingMessage networkcon + Just ncToPartner -> do + recievedNetLog message $ "Recieved message as: " ++ ncOwnUserID ncToPartner ++ " (" ++ ownport ++ ") from: " ++ ncPartnerUserID ncToPartner + busy <- SSem.tryWait $ ncHandlingIncomingMessage ncToPartner case busy of Just num -> do - constate <- MVar.readMVar $ ncConnectionState networkcon + constate <- MVar.readMVar $ ncConnectionState ncToPartner reply <- case constate of RedirectRequest _ _ host port _ _ _ -> do recievedNetLog message $ "Found redirect request for: " ++ userid recievedNetLog message $ "Send redirect to:" ++ host ++ ":" ++ port - SSem.signal $ ncHandlingIncomingMessage networkcon + SSem.signal $ ncHandlingIncomingMessage ncToPartner NC.sendResponse hdl (Messages.Redirect host port) Connected {} -> case deserialmessages of NewValue userid count val -> do - -- DC.lockInterpreterReads (ncRead networkcon) - success <- NB.writeIfNext (ncRead networkcon) count $ setPartnerHostAddress clientHostaddress val - SSem.signal $ ncHandlingIncomingMessage networkcon + -- DC.lockInterpreterReads (ncRead ncToPartner) + success <- NB.writeIfNext (ncRead ncToPartner) count $ setPartnerHostAddress clientHostaddress val + SSem.signal $ ncHandlingIncomingMessage ncToPartner if success then recievedNetLog message "Message written to Channel" else recievedNetLog message "Message not correct" NC.sendResponse hdl Messages.Okay recievedNetLog message "Sent okay" - -- DC.unlockInterpreterReads (ncRead networkcon) + -- DC.unlockInterpreterReads (ncRead ncToPartner) RequestValue userid count -> do - SSem.signal $ ncHandlingIncomingMessage networkcon + SSem.signal $ ncHandlingIncomingMessage ncToPartner NC.sendResponse hdl Messages.Okay - mbyval <- NB.tryGetAtNB (NCon.ncWrite networkcon) count - Data.Maybe.maybe (return False) (\val -> NClient.sendNetworkMessage activeCons networkcon (Messages.NewValue (ncOwnUserID networkcon) count val) 0) mbyval + mbyval <- NB.tryGetAtNB (NCon.ncWrite ncToPartner) count + Data.Maybe.maybe (return False) (\val -> NClient.sendNetworkMessage activeCons ncToPartner (Messages.NewValue (ncOwnUserID ncToPartner) count val) 0) mbyval return () AcknowledgeValue userid count -> do NC.sendResponse hdl Messages.Okay -- This okay is needed here to fix a race-condition with disconnects being faster than the okay - -- NB.serialize (ncWrite networkcon) >>= \x -> Config.traceNetIO $ "Online before acknowlegment: " ++ show x - NB.updateAcknowledgements (NCon.ncWrite networkcon) count - SSem.signal $ ncHandlingIncomingMessage networkcon + -- NB.serialize (ncWrite ncToPartner) >>= \x -> Config.traceNetIO $ "Online before acknowlegment: " ++ show x + NB.updateAcknowledgements (NCon.ncWrite ncToPartner) count + SSem.signal $ ncHandlingIncomingMessage ncToPartner NewPartnerAddress userid port connectionID -> do recievedNetLog message $ "Trying to change the address to: " ++ clientHostaddress ++ ":" ++ port - NCon.changePartnerAddress networkcon clientHostaddress port connectionID - SSem.signal $ ncHandlingIncomingMessage networkcon + NCon.changePartnerAddress ncToPartner clientHostaddress port connectionID + SSem.signal $ ncHandlingIncomingMessage ncToPartner NC.sendResponse hdl Messages.Okay - NClient.sendNetworkMessage activeCons networkcon (Messages.AcknowledgePartnerAddress (ncOwnUserID networkcon) connectionID) 0 + NClient.sendNetworkMessage activeCons ncToPartner (Messages.AcknowledgePartnerAddress (ncOwnUserID ncToPartner) connectionID) 0 return () AcknowledgePartnerAddress userid connectionID -> do - conConfirmed <- NCon.confirmConnectionID networkcon connectionID - SSem.signal $ ncHandlingIncomingMessage networkcon + conConfirmed <- NCon.confirmConnectionID ncToPartner connectionID + SSem.signal $ ncHandlingIncomingMessage ncToPartner if conConfirmed then NC.sendResponse hdl Messages.Okay else NC.sendResponse hdl Messages.Error Disconnect userid -> do - NCon.disconnectFromPartner networkcon - SSem.signal $ ncHandlingIncomingMessage networkcon + NCon.disconnectFromPartner ncToPartner + SSem.signal $ ncHandlingIncomingMessage ncToPartner NC.sendResponse hdl Messages.Okay _ -> do serial <- NSerialize.serialize deserialmessages recievedNetLog message $ "Error unsupported networkmessage: "++ serial - SSem.signal $ ncHandlingIncomingMessage networkcon + SSem.signal $ ncHandlingIncomingMessage ncToPartner NC.sendResponse hdl Messages.Okay _ -> do recievedNetLog message "Network Connection is in a illegal state!" - SSem.signal $ ncHandlingIncomingMessage networkcon + SSem.signal $ ncHandlingIncomingMessage ncToPartner NC.sendResponse hdl Messages.Okay return reply Nothing -> do recievedNetLog message "Message cannot be handled at the moment! Sending wait response" - SSem.signal $ ncHandlingIncomingMessage networkcon + SSem.signal $ ncHandlingIncomingMessage ncToPartner NC.sendResponse hdl Messages.Wait Nothing -> do From 432bff0187ab3b701cb27a2e1d6c7262dc14a23b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 22 Feb 2023 16:18:01 +0100 Subject: [PATCH 162/229] Lowered Code duplication --- src/Networking/Client.hs | 17 +++++++-- src/Networking/Server.hs | 17 +++++++++ src/ProcessEnvironmentTypes.hs | 66 ++++++++++++++++++++++++++++++++++ 3 files changed, 98 insertions(+), 2 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index abbaa12..f1b0fe6 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -37,12 +37,12 @@ sendValue vchanconsmvar activeCons networkconnection val ownport resendOnError = case connectionstate of Connected hostname port _ _ _ -> do setRedirectRequests vchanconsmvar hostname port ownport val - valcleaned <- replaceVChan val + valcleaned <- serializeVChan val messagesCount <- NB.write (ncWrite networkconnection) valcleaned tryToSendNetworkMessage activeCons networkconnection hostname port (Messages.NewValue (ncOwnUserID networkconnection) messagesCount valcleaned) resendOnError Emulated {} -> do vchancons <- MVar.readMVar vchanconsmvar - valCleaned <- replaceVChan val + valCleaned <- serializeVChan val NB.write(ncWrite networkconnection) valCleaned let ownid = ncOwnUserID networkconnection let mbypartner = Map.lookup ownid vchancons @@ -214,6 +214,17 @@ setRedirectRequests vchanconmvar newhost newport ownport input = case input of setRedirectRequests vchanconmvar newhost newport ownport $ snd x setRedirectRequestsPEnv vchanconmvar newhost newport ownport xs +serializeVChan :: Value -> IO Value +serializeVChan = modifyVChans handleVChan + where + handleVChan :: Value -> IO Value + handleVChan input = case input of + VChan nc _-> do + (r, ro, rl, w, wo, wl, pid, oid, h, p, partConID) <- serializeNetworkConnection nc + return $ VChanSerial (r, ro, rl) (w, wo, wl) pid oid (h, p, partConID) + _ -> return input + +{- replaceVChan :: Value -> IO Value replaceVChan input = case input of VSend v -> do @@ -249,6 +260,8 @@ replaceVChan input = case input of newval <- replaceVChan $ snd x rest <- replaceVChanPEnv xs return $ (fst x, newval):rest +-} + sendDisconnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> IO () sendDisconnect ac mvar = do diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 651b948..38b1060 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -236,6 +236,22 @@ findFittingClient clientlist desiredType = do threadDelay 10000 -- Sleep for 10 ms to not hammer the CPU findFittingClient clientlist desiredType +replaceVChanSerial :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> Value -> IO Value +replaceVChanSerial activeCons mvar input = modifyVChans (handleSerial activeCons mvar) input + where + handleSerial :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> Value -> IO Value + handleSerial activeCons mvar input = case input of + VChanSerial r w p o c -> do + networkconnection <- createNetworkConnection r w p o c + ncmap <- MVar.takeMVar mvar + MVar.putMVar mvar $ Map.insert p networkconnection ncmap + used<- MVar.newEmptyMVar + MVar.putMVar used False + return $ VChan networkconnection used + _ -> return input + + +{- replaceVChanSerial :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> Value -> IO Value replaceVChanSerial activeCons mvar input = case input of VSend v -> do @@ -275,6 +291,7 @@ replaceVChanSerial activeCons mvar input = case input of newval <- replaceVChanSerial activeCons mvar $ snd x rest <- replaceVChanSerialPEnv activeCons mvar xs return $ (fst x, newval):rest +-} recieveValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value recieveValue vchanconsvar activeCons networkconnection ownport = do diff --git a/src/ProcessEnvironmentTypes.hs b/src/ProcessEnvironmentTypes.hs index 6d65ad2..d4e6561 100644 --- a/src/ProcessEnvironmentTypes.hs +++ b/src/ProcessEnvironmentTypes.hs @@ -53,6 +53,72 @@ data Value | VNewNatRec PEnv String String String Type Exp String Exp deriving Eq +modifyVChans :: (Value -> IO Value) -> Value -> IO Value +modifyVChans vchanhandler input = case input of + VSend v -> do + nv <- modifyVChans vchanhandler v + return $ VSend nv + VPair v1 v2 -> do + nv1 <- modifyVChans vchanhandler v1 + nv2 <- modifyVChans vchanhandler v2 + return $ VPair nv1 nv2 + VFunc penv a b -> do + newpenv <- modifyVChansPEnv vchanhandler penv + return $ VFunc newpenv a b + VDynCast v g -> do + nv <- modifyVChans vchanhandler v + return $ VDynCast nv g + VFuncCast v a b -> do + nv <- modifyVChans vchanhandler v + return $ VFuncCast nv a b + VRec penv a b c d -> do + newpenv <- modifyVChansPEnv vchanhandler penv + return $ VRec newpenv a b c d + VNewNatRec penv a b c d e f g -> do + newpenv <- modifyVChansPEnv vchanhandler penv + return $ VNewNatRec newpenv a b c d e f g + VChan nc used-> vchanhandler input + VChanSerial r w p o c -> vchanhandler input + _ -> return input + where + modifyVChansPEnv :: (Value -> IO Value) -> [(String, Value)] -> IO [(String, Value)] + modifyVChansPEnv _ [] = return [] + modifyVChansPEnv vchanhandler penvs@(x:xs) = do + newval <- modifyVChans vchanhandler $ snd x + rest <- modifyVChansPEnv vchanhandler xs + return $ (fst x, newval):rest + +-- type ModifyVChansResult = r +{- +modifyVChans :: (Value -> r) -> (Value -> r) -> (Value -> r) -> (Value -> r -> r) -> (Value -> r -> r -> r) -> (Value -> [(String, r)] -> r) -> Value -> r +modifyVChans vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv input = case input of + VSend v -> wrapResult input $ modifyVChans vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv v + VPair v1 v2 -> + let nv1 = modifyVChans vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv v1 in + let nv2 = modifyVChans vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv v2 in + mergeResults input nv1 nv2 + VFunc penv a b -> + let newpenv = modifyVChansPEnv vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv penv in + mergeResultsPEnv input newpenv + VDynCast v g -> wrapResult input $ modifyVChans vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv v + VFuncCast v a b -> wrapResult input $ modifyVChans vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv v + VRec penv a b c d -> + let newpenv = modifyVChansPEnv vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv penv in + mergeResultsPEnv input newpenv + VNewNatRec penv a b c d e f g -> + let newpenv = modifyVChansPEnv vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv penv in + mergeResultsPEnv input newpenv + VChan nc used-> vchanhandler input + VChanSerial r w p o c -> vchanserialhandler input + _ -> defaultResult input + where + modifyVChansPEnv :: (Value -> r) -> (Value -> r) -> (Value -> r) -> (Value -> r -> r) -> (Value -> r -> r -> r) -> (Value -> [(String, r)] -> r) -> [(String, Value)] -> [(String, r)] + modifyVChansPEnv _ _ _ _ _ _[] = [] + modifyVChansPEnv vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv penvs@(x:xs) = + let newval = modifyVChans vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv $ snd x in + (fst x, newval):modifyVChansPEnv vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv xs +-} + disableOldVChan :: Value -> IO Value disableOldVChan value = case value of VChan nc used -> do From 7ccc6894e0da648850a747d02fa9617234d45bbe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 22 Feb 2023 17:02:37 +0100 Subject: [PATCH 163/229] Removed duplicated code --- src/Networking/Client.hs | 120 ++++++++++----------------------- src/Networking/Server.hs | 97 +++++--------------------- src/ProcessEnvironmentTypes.hs | 25 +++++++ 3 files changed, 75 insertions(+), 167 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index f1b0fe6..5f20556 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -10,7 +10,6 @@ import qualified Networking.NetworkBuffer as NB import qualified Networking.Messages as Messages import qualified Networking.RandomID as RandomID import qualified Data.Map as Map -import qualified Data.Maybe import Control.Concurrent import Control.Exception import qualified Syntax @@ -166,53 +165,41 @@ initialConnect activeCons mvar hostname port ownport syntype= do threadDelay 1000000 initialConnect activeCons mvar hostname port ownport syntype --- This is still broken -setRedirectRequests :: VChanConnections -> String -> String -> String -> Value -> IO () -setRedirectRequests vchanconmvar newhost newport ownport input = case input of - VSend v -> setRedirectRequests vchanconmvar newhost newport ownport v - VPair v1 v2 -> do - setRedirectRequests vchanconmvar newhost newport ownport v1 - setRedirectRequests vchanconmvar newhost newport ownport v2 - VFunc penv a b -> setRedirectRequestsPEnv vchanconmvar newhost newport ownport penv - VDynCast v g -> setRedirectRequests vchanconmvar newhost newport ownport v - VFuncCast v a b -> setRedirectRequests vchanconmvar newhost newport ownport v - VRec penv a b c d -> setRedirectRequestsPEnv vchanconmvar newhost newport ownport penv - VNewNatRec penv a b c d e f g -> setRedirectRequestsPEnv vchanconmvar newhost newport ownport penv - VChan nc _ -> do - Config.traceNetIO $ "Trying to set RedirectRequest for " ++ ncPartnerUserID nc ++ " to " ++ newhost ++ ":" ++ newport - - SSem.withSem (ncHandlingIncomingMessage nc) (do - oldconnectionstate <- MVar.takeMVar $ ncConnectionState nc - case oldconnectionstate of - Connected hostname port partConID ownConID confirmed -> MVar.putMVar (ncConnectionState nc) $ RedirectRequest hostname port newhost newport partConID ownConID confirmed - RedirectRequest hostname port _ _ partConID ownConID confirmed -> MVar.putMVar (ncConnectionState nc) $ RedirectRequest hostname port newhost newport partConID ownConID confirmed - Emulated partConID ownConID confirmed -> do - Config.traceNetIO "TODO: Allow RedirectRequest for Emulated channel" - vchanconnections <- MVar.takeMVar vchanconmvar - - let userid = ncOwnUserID nc - let mbypartner = Map.lookup userid vchanconnections - case mbypartner of - Just partner -> do - MVar.putMVar (ncConnectionState nc) $ RedirectRequest "" ownport newhost newport partConID ownConID confirmed -- Setting this to 127.0.0.1 is a temporary hack - oldconectionstatePartner <- MVar.takeMVar $ ncConnectionState partner - MVar.putMVar (ncConnectionState partner) $ Connected newhost newport partConID ownConID confirmed - Nothing -> do - MVar.putMVar (ncConnectionState nc) oldconnectionstate - Config.traceNetIO "Error occured why getting the linked emulated channel" - - - MVar.putMVar vchanconmvar vchanconnections - Disconnected partConID ownConID confirmed -> Config.traceNetIO "Cannot set RedirectRequest for a disconnected channel" - ) - Config.traceNetIO $ "Set RedirectRequest for " ++ ncPartnerUserID nc ++ " to " ++ newhost ++ ":" ++ newport - _ -> return () +setRedirectRequests :: VChanConnections -> String -> String -> String -> Value -> IO Bool +setRedirectRequests vchanconmvar newhost newport ownport = searchVChans (handleVChan vchanconmvar newhost newport ownport) True (&&) where - setRedirectRequestsPEnv :: VChanConnections -> String -> String -> String -> [(String, Value)] -> IO () - setRedirectRequestsPEnv _ _ _ _ [] = return () - setRedirectRequestsPEnv vchanconmvar newhost newport ownport (x:xs) = do - setRedirectRequests vchanconmvar newhost newport ownport $ snd x - setRedirectRequestsPEnv vchanconmvar newhost newport ownport xs + handleVChan :: VChanConnections -> String -> String -> String -> Value -> IO Bool + handleVChan vchanconmvar newhost newport ownport input = case input of + VChan nc _ -> do + Config.traceNetIO $ "Trying to set RedirectRequest for " ++ ncPartnerUserID nc ++ " to " ++ newhost ++ ":" ++ newport + + SSem.withSem (ncHandlingIncomingMessage nc) (do + oldconnectionstate <- MVar.takeMVar $ ncConnectionState nc + case oldconnectionstate of + Connected hostname port partConID ownConID confirmed -> MVar.putMVar (ncConnectionState nc) $ RedirectRequest hostname port newhost newport partConID ownConID confirmed + RedirectRequest hostname port _ _ partConID ownConID confirmed -> MVar.putMVar (ncConnectionState nc) $ RedirectRequest hostname port newhost newport partConID ownConID confirmed + Emulated partConID ownConID confirmed -> do + Config.traceNetIO "TODO: Allow RedirectRequest for Emulated channel" + vchanconnections <- MVar.takeMVar vchanconmvar + + let userid = ncOwnUserID nc + let mbypartner = Map.lookup userid vchanconnections + case mbypartner of + Just partner -> do + MVar.putMVar (ncConnectionState nc) $ RedirectRequest "" ownport newhost newport partConID ownConID confirmed -- Setting this to 127.0.0.1 is a temporary hack + oldconectionstatePartner <- MVar.takeMVar $ ncConnectionState partner + MVar.putMVar (ncConnectionState partner) $ Connected newhost newport partConID ownConID confirmed + Nothing -> do + MVar.putMVar (ncConnectionState nc) oldconnectionstate + Config.traceNetIO "Error occured why getting the linked emulated channel" + + + MVar.putMVar vchanconmvar vchanconnections + Disconnected partConID ownConID confirmed -> Config.traceNetIO "Cannot set RedirectRequest for a disconnected channel" + ) + Config.traceNetIO $ "Set RedirectRequest for " ++ ncPartnerUserID nc ++ " to " ++ newhost ++ ":" ++ newport + return True + _ -> return True serializeVChan :: Value -> IO Value serializeVChan = modifyVChans handleVChan @@ -224,45 +211,6 @@ serializeVChan = modifyVChans handleVChan return $ VChanSerial (r, ro, rl) (w, wo, wl) pid oid (h, p, partConID) _ -> return input -{- -replaceVChan :: Value -> IO Value -replaceVChan input = case input of - VSend v -> do - nv <- replaceVChan v - return $ VSend nv - VPair v1 v2 -> do - nv1 <- replaceVChan v1 - nv2 <- replaceVChan v2 - return $ VPair nv1 nv2 - VFunc penv a b -> do - newpenv <- replaceVChanPEnv penv - return $ VFunc newpenv a b - VDynCast v g -> do - nv <- replaceVChan v - return $ VDynCast nv g - VFuncCast v a b -> do - nv <- replaceVChan v - return $ VFuncCast nv a b - VRec penv a b c d -> do - newpenv <- replaceVChanPEnv penv - return $ VRec newpenv a b c d - VNewNatRec penv a b c d e f g -> do - newpenv <- replaceVChanPEnv penv - return $ VNewNatRec newpenv a b c d e f g - VChan nc _-> do - (r, ro, rl, w, wo, wl, pid, oid, h, p, partConID) <- serializeNetworkConnection nc - return $ VChanSerial (r, ro, rl) (w, wo, wl) pid oid (h, p, partConID) - _ -> return input - where - replaceVChanPEnv :: [(String, Value)] -> IO [(String, Value)] - replaceVChanPEnv [] = return [] - replaceVChanPEnv (x:xs) = do - newval <- replaceVChan $ snd x - rest <- replaceVChanPEnv xs - return $ (fst x, newval):rest --} - - sendDisconnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> IO () sendDisconnect ac mvar = do networkConnectionMap <- MVar.readMVar mvar diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 38b1060..fbe543a 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -162,47 +162,25 @@ setPartnerHostAddress address input = case input of waitUntilContactedNewPeers :: NMC.ActiveConnections -> Value -> String -> IO () waitUntilContactedNewPeers activeCons input ownport = do - contactedPeers <- contactNewPeers activeCons input ownport + contactedPeers <- contactNewPeers activeCons ownport input unless contactedPeers $ do threadDelay 50000 waitUntilContactedNewPeers activeCons input ownport - -contactNewPeers :: NMC.ActiveConnections -> Value -> String -> IO Bool -contactNewPeers activeCons input ownport = case input of - VSend v -> do - contactNewPeers activeCons v ownport - VPair v1 v2 -> do - nv1 <- contactNewPeers activeCons v1 ownport - nv2 <- contactNewPeers activeCons v2 ownport - return (nv1 || nv2) - VFunc penv a b -> do - contactNewPeersPEnv activeCons penv ownport - VDynCast v g -> do - contactNewPeers activeCons v ownport - VFuncCast v a b -> do - contactNewPeers activeCons v ownport - VRec penv a b c d -> do - contactNewPeersPEnv activeCons penv ownport - VNewNatRec penv a b c d e f g -> do - contactNewPeersPEnv activeCons penv ownport - VChan nc bool -> do - connectionState <- MVar.readMVar $ ncConnectionState nc - case connectionState of - Emulated {} -> return True - _ -> do - if csConfirmedConnection connectionState then return True else do - NClient.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) 0 - return False - _ -> return True +contactNewPeers :: NMC.ActiveConnections -> String -> Value -> IO Bool +contactNewPeers activeCons ownport = searchVChans (handleVChan activeCons ownport) True (&&) where - contactNewPeersPEnv :: NMC.ActiveConnections -> [(String, Value)] -> String -> IO Bool -- [(String, Value)] - contactNewPeersPEnv _ [] _ = return True - contactNewPeersPEnv activeCons (x:xs) ownport = do - newval <- contactNewPeers activeCons (snd x) ownport - rest <- contactNewPeersPEnv activeCons xs ownport - -- return $ (fst x, newval):rest - return (newval || rest) + handleVChan :: NMC.ActiveConnections -> String -> Value -> IO Bool + handleVChan activeCons ownport input = case input of + VChan nc bool -> do + connectionState <- MVar.readMVar $ ncConnectionState nc + case connectionState of + Emulated {} -> return True + _ -> do + if csConfirmedConnection connectionState then return True else do + NClient.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) 0 + return False + _ -> return True hostaddressTypeToString :: HostAddress -> String hostaddressTypeToString hostaddress = do @@ -238,7 +216,7 @@ findFittingClient clientlist desiredType = do replaceVChanSerial :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> Value -> IO Value replaceVChanSerial activeCons mvar input = modifyVChans (handleSerial activeCons mvar) input - where + where handleSerial :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> Value -> IO Value handleSerial activeCons mvar input = case input of VChanSerial r w p o c -> do @@ -250,49 +228,6 @@ replaceVChanSerial activeCons mvar input = modifyVChans (handleSerial activeCons return $ VChan networkconnection used _ -> return input - -{- -replaceVChanSerial :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> Value -> IO Value -replaceVChanSerial activeCons mvar input = case input of - VSend v -> do - nv <- replaceVChanSerial activeCons mvar v - return $ VSend nv - VPair v1 v2 -> do - nv1 <- replaceVChanSerial activeCons mvar v1 - nv2 <- replaceVChanSerial activeCons mvar v2 - return $ VPair nv1 nv2 - VFunc penv a b -> do - newpenv <- replaceVChanSerialPEnv activeCons mvar penv - return $ VFunc newpenv a b - VDynCast v g -> do - nv <- replaceVChanSerial activeCons mvar v - return $ VDynCast nv g - VFuncCast v a b -> do - nv <- replaceVChanSerial activeCons mvar v - return $ VFuncCast nv a b - VRec penv a b c d -> do - newpenv <- replaceVChanSerialPEnv activeCons mvar penv - return $ VRec newpenv a b c d - VNewNatRec penv a b c d e f g -> do - newpenv <- replaceVChanSerialPEnv activeCons mvar penv - return $ VNewNatRec newpenv a b c d e f g - VChanSerial r w p o c -> do - networkconnection <- createNetworkConnection r w p o c - ncmap <- MVar.takeMVar mvar - MVar.putMVar mvar $ Map.insert p networkconnection ncmap - used<- MVar.newEmptyMVar - MVar.putMVar used False - return $ VChan networkconnection used - _ -> return input - where - replaceVChanSerialPEnv :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> [(String, Value)] -> IO [(String, Value)] - replaceVChanSerialPEnv _ _ [] = return [] - replaceVChanSerialPEnv activeCons mvar (x:xs) = do - newval <- replaceVChanSerial activeCons mvar $ snd x - rest <- replaceVChanSerialPEnv activeCons mvar xs - return $ (fst x, newval):rest --} - recieveValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value recieveValue vchanconsvar activeCons networkconnection ownport = do recieveValueInternal 0 vchanconsvar activeCons networkconnection ownport @@ -320,7 +255,7 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do return True _ -> Config.traceNetIO "Something went wrong when acknowleding value of emulated connection" >> return True _ -> return True - + return val Nothing -> if count == 0 then do msgCount <- NB.getNextOffset $ ncRead networkconnection diff --git a/src/ProcessEnvironmentTypes.hs b/src/ProcessEnvironmentTypes.hs index d4e6561..de23fa2 100644 --- a/src/ProcessEnvironmentTypes.hs +++ b/src/ProcessEnvironmentTypes.hs @@ -88,6 +88,31 @@ modifyVChans vchanhandler input = case input of rest <- modifyVChansPEnv vchanhandler xs return $ (fst x, newval):rest +searchVChans :: (Value -> IO r) -> r -> (r -> r -> r) -> Value -> IO r +searchVChans vchanhandler defaultResult mergeResults input = case input of + VSend v -> searchVChans vchanhandler defaultResult mergeResults v + + VPair v1 v2 -> do + nv1 <- searchVChans vchanhandler defaultResult mergeResults v1 + nv2 <- searchVChans vchanhandler defaultResult mergeResults v2 + return $ mergeResults nv1 nv2 + VFunc penv a b -> searchVChansPEnv vchanhandler defaultResult mergeResults penv + VDynCast v g -> searchVChans vchanhandler defaultResult mergeResults v + VFuncCast v a b -> searchVChans vchanhandler defaultResult mergeResults v + VRec penv a b c d -> searchVChansPEnv vchanhandler defaultResult mergeResults penv + VNewNatRec penv a b c d e f g -> searchVChansPEnv vchanhandler defaultResult mergeResults penv + VChan nc used-> vchanhandler input + VChanSerial r w p o c -> vchanhandler input + _ -> return defaultResult + where + searchVChansPEnv :: (Value -> IO r) -> r -> (r -> r -> r) -> [(String, Value)] -> IO r + searchVChansPEnv _ defaultResult _ [] = return defaultResult + searchVChansPEnv vchanhandler defaultResult mergeResults penvs@(x:xs) = do + newval <- searchVChans vchanhandler defaultResult mergeResults $ snd x + rest <- searchVChansPEnv vchanhandler defaultResult mergeResults xs + return $ mergeResults newval rest + + -- type ModifyVChansResult = r {- modifyVChans :: (Value -> r) -> (Value -> r) -> (Value -> r) -> (Value -> r -> r) -> (Value -> r -> r -> r) -> (Value -> [(String, r)] -> r) -> Value -> r From c4701be090310d5668a85854af0c6b9130a1d7d6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 22 Feb 2023 17:03:56 +0100 Subject: [PATCH 164/229] Update ProcessEnvironmentTypes.hs --- src/ProcessEnvironmentTypes.hs | 32 -------------------------------- 1 file changed, 32 deletions(-) diff --git a/src/ProcessEnvironmentTypes.hs b/src/ProcessEnvironmentTypes.hs index de23fa2..076d0fa 100644 --- a/src/ProcessEnvironmentTypes.hs +++ b/src/ProcessEnvironmentTypes.hs @@ -112,38 +112,6 @@ searchVChans vchanhandler defaultResult mergeResults input = case input of rest <- searchVChansPEnv vchanhandler defaultResult mergeResults xs return $ mergeResults newval rest - --- type ModifyVChansResult = r -{- -modifyVChans :: (Value -> r) -> (Value -> r) -> (Value -> r) -> (Value -> r -> r) -> (Value -> r -> r -> r) -> (Value -> [(String, r)] -> r) -> Value -> r -modifyVChans vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv input = case input of - VSend v -> wrapResult input $ modifyVChans vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv v - VPair v1 v2 -> - let nv1 = modifyVChans vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv v1 in - let nv2 = modifyVChans vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv v2 in - mergeResults input nv1 nv2 - VFunc penv a b -> - let newpenv = modifyVChansPEnv vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv penv in - mergeResultsPEnv input newpenv - VDynCast v g -> wrapResult input $ modifyVChans vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv v - VFuncCast v a b -> wrapResult input $ modifyVChans vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv v - VRec penv a b c d -> - let newpenv = modifyVChansPEnv vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv penv in - mergeResultsPEnv input newpenv - VNewNatRec penv a b c d e f g -> - let newpenv = modifyVChansPEnv vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv penv in - mergeResultsPEnv input newpenv - VChan nc used-> vchanhandler input - VChanSerial r w p o c -> vchanserialhandler input - _ -> defaultResult input - where - modifyVChansPEnv :: (Value -> r) -> (Value -> r) -> (Value -> r) -> (Value -> r -> r) -> (Value -> r -> r -> r) -> (Value -> [(String, r)] -> r) -> [(String, Value)] -> [(String, r)] - modifyVChansPEnv _ _ _ _ _ _[] = [] - modifyVChansPEnv vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv penvs@(x:xs) = - let newval = modifyVChans vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv $ snd x in - (fst x, newval):modifyVChansPEnv vchanhandler vchanserialhandler defaultResult wrapResult mergeResults mergeResultsPEnv xs --} - disableOldVChan :: Value -> IO Value disableOldVChan value = case value of VChan nc used -> do From 6455f6f9d4b367e95420f0cad1dce9fecea8c6ce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 22 Feb 2023 17:25:49 +0100 Subject: [PATCH 165/229] Simplified code --- src/Networking/Server.hs | 33 +++++++-------------------------- src/ProcessEnvironmentTypes.hs | 33 +++++++++++++++++++++++++++++++++ 2 files changed, 40 insertions(+), 26 deletions(-) diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index fbe543a..063524f 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -132,33 +132,14 @@ recievedNetLog :: String -> String -> IO () recievedNetLog msg info = Config.traceNetIO $ "Recieved message: "++msg++" \n Status: "++info setPartnerHostAddress :: String -> Value -> Value -setPartnerHostAddress address input = case input of - VSend v -> VSend $ setPartnerHostAddress address v - VPair v1 v2 -> - let nv1 = setPartnerHostAddress address v1 in - let nv2 = setPartnerHostAddress address v2 in - VPair nv1 nv2 - VFunc penv a b -> - let newpenv = setPartnerHostAddressPEnv address penv in - VFunc newpenv a b - VDynCast v g -> VDynCast (setPartnerHostAddress address v) g - VFuncCast v a b -> VFuncCast (setPartnerHostAddress address v) a b - VRec penv a b c d -> - let newpenv = setPartnerHostAddressPEnv address penv in - VRec newpenv a b c d - VNewNatRec penv a b c d e f g -> - let newpenv = setPartnerHostAddressPEnv address penv in - VNewNatRec newpenv a b c d e f g - VChanSerial r w p o c -> do - let (hostname, port, partnerID) = c - VChanSerial r w p o (if hostname == "" then address else hostname, port, partnerID) - _ -> input -- return input +setPartnerHostAddress address = modifyVChansStatic (handleSerial address) where - setPartnerHostAddressPEnv :: String -> [(String, Value)] -> [(String, Value)] - setPartnerHostAddressPEnv _ [] = [] - setPartnerHostAddressPEnv clientHostaddress penvs@(x:xs) = - let newval = setPartnerHostAddress clientHostaddress $ snd x in - (fst x, newval):setPartnerHostAddressPEnv clientHostaddress xs + handleSerial :: String -> Value -> Value + handleSerial address input = case input of + VChanSerial r w p o c -> do + let (hostname, port, partnerID) = c + VChanSerial r w p o (if hostname == "" then address else hostname, port, partnerID) + _ -> input -- return input waitUntilContactedNewPeers :: NMC.ActiveConnections -> Value -> String -> IO () waitUntilContactedNewPeers activeCons input ownport = do diff --git a/src/ProcessEnvironmentTypes.hs b/src/ProcessEnvironmentTypes.hs index 076d0fa..b2dd399 100644 --- a/src/ProcessEnvironmentTypes.hs +++ b/src/ProcessEnvironmentTypes.hs @@ -53,6 +53,39 @@ data Value | VNewNatRec PEnv String String String Type Exp String Exp deriving Eq + +modifyVChansStatic :: (Value -> Value) -> Value -> Value +modifyVChansStatic vchanhandler input = case input of + VSend v -> VSend $ modifyVChansStatic vchanhandler v + VPair v1 v2 -> do + let nv1 = modifyVChansStatic vchanhandler v1 + let nv2 = modifyVChansStatic vchanhandler v2 + VPair nv1 nv2 + VFunc penv a b -> do + let newpenv = modifyVChansPEnvStatic vchanhandler penv + VFunc newpenv a b + VDynCast v g -> do + let nv = modifyVChansStatic vchanhandler v + VDynCast nv g + VFuncCast v a b -> do + let nv = modifyVChansStatic vchanhandler v + VFuncCast nv a b + VRec penv a b c d -> do + let newpenv = modifyVChansPEnvStatic vchanhandler penv + VRec newpenv a b c d + VNewNatRec penv a b c d e f g -> do + let newpenv = modifyVChansPEnvStatic vchanhandler penv + VNewNatRec newpenv a b c d e f g + VChan nc used-> vchanhandler input + VChanSerial r w p o c -> vchanhandler input + _ -> input + where + modifyVChansPEnvStatic :: (Value -> Value) -> [(String, Value)] -> [(String, Value)] + modifyVChansPEnvStatic _ [] = [] + modifyVChansPEnvStatic vchanhandler penvs@(x:xs) = do + let newval = modifyVChansStatic vchanhandler $ snd x + (fst x, newval):modifyVChansPEnvStatic vchanhandler xs + modifyVChans :: (Value -> IO Value) -> Value -> IO Value modifyVChans vchanhandler input = case input of VSend v -> do From 2c3113e89462151eaaaaa05cdc13ad37491a5645 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 22 Feb 2023 18:33:25 +0100 Subject: [PATCH 166/229] Update RandomID.hs --- src/Networking/RandomID.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Networking/RandomID.hs b/src/Networking/RandomID.hs index 557e0e0..3578e2b 100644 --- a/src/Networking/RandomID.hs +++ b/src/Networking/RandomID.hs @@ -12,4 +12,4 @@ mapToChar val newRandomID :: IO String newRandomID = map mapToChar . take 8 . randomRs (0, 61) <$> newStdGen --- newRandomUserID = map mapToChar . take 128 . randomRs (0, 61) <$> newStdGen +-- newRandomID = map mapToChar . take 128 . randomRs (0, 61) <$> newStdGen From d017ba290f6e80e6dd5760dbc9b30bcc2e4bc73e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 23 Feb 2023 13:05:54 +0100 Subject: [PATCH 167/229] Work towards making the Disconnect command obsolete in the future --- ldgv.cabal | 2 ++ src/Networking/Assert.hs | 19 ++++++++++++++ src/Networking/Client.hs | 38 ++++++++++++++++++++++++++++ src/Networking/Server.hs | 1 + src/Networking/Tests.hs | 54 ++++++++++++++++++++++++++++++++++++++++ testOftenHandoff.sh | 3 +++ 6 files changed, 117 insertions(+) create mode 100644 src/Networking/Assert.hs create mode 100644 src/Networking/Tests.hs create mode 100644 testOftenHandoff.sh diff --git a/ldgv.cabal b/ldgv.cabal index 1aeca8c..de9cc91 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -66,6 +66,7 @@ library Examples Interpreter Kinds + Networking.Assert Networking.Buffer Networking.Client Networking.Common @@ -78,6 +79,7 @@ library Networking.RandomID Networking.Serialize Networking.Server + Networking.Tests Parsing Parsing.Grammar Parsing.Tokens diff --git a/src/Networking/Assert.hs b/src/Networking/Assert.hs new file mode 100644 index 0000000..7385142 --- /dev/null +++ b/src/Networking/Assert.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE LambdaCase #-} + +module Networking.Assert where + +import Control.Exception + + +newtype AssertException = TestErrorAssertEQ String + +instance Show AssertException where + show = \case + TestErrorAssertEQ err -> "AssertException (TestErrorAssertEQ): " ++ err + + +instance Exception AssertException + + +assertEQ :: Eq a => String -> a -> a -> IO () +assertEQ err v1 v2 = if v1==v2 then putStrLn $ "Assertion Success: "++ err else throw $ TestErrorAssertEQ err \ No newline at end of file diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 5f20556..50e4abc 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -211,6 +211,44 @@ serializeVChan = modifyVChans handleVChan return $ VChanSerial (r, ro, rl) (w, wo, wl) pid oid (h, p, partConID) _ -> return input +{- +sendDisconnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> IO () +sendDisconnect ac mvar = do + networkConnectionMap <- MVar.readMVar mvar + let allNetworkConnections = Map.elems networkConnectionMap + goodbyes <- doForall ac allNetworkConnections + unless goodbyes $ do + threadDelay 100000 + sendDisconnect ac mvar + where + doForall ac (x:xs) = do + xres <- sendDisconnectNetworkConnection ac x + rest <- doForall ac xs + return $ xres && rest + doForall ac [] = return True + sendDisconnectNetworkConnection :: NMC.ActiveConnections -> NetworkConnection Value -> IO Bool + sendDisconnectNetworkConnection ac con = do + let writeVals = ncWrite con + connectionState <- MVar.readMVar $ ncConnectionState con + -- unreadVals <- DC.unreadMessageStart writeVals + -- lengthVals <- DC.countMessages writeVals + -- Config.traceNetIO "Checking if everything is acknowledged" + -- NB.serialize writeVals >>= Config.traceNetIO . show + -- NB.isAllAcknowledged writeVals >>= Config.traceNetIO . show + case connectionState of + -- Connected host port _ _ _ -> if unreadVals >= lengthVals then do + Connected host port _ _ _ -> do + count <- NB.getNextOffset (ncRead con) + if count == 0 then return True else catch (sendNetworkMessage ac con (Messages.AcknowledgeValue (ncOwnUserID con) $ count-1) 0) $ printConErr host port + -- ret <- NB.isAllAcknowledged writeVals + -- writeValsSer <- NB.serialize writeVals + -- Config.traceNetIO $ show writeValsSer ++ "\n " ++ if ret then "All acknowledged" else "Not completely acknowledged" + -- return ret + NB.isAllAcknowledged writeVals + _ -> return True +-} + + sendDisconnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> IO () sendDisconnect ac mvar = do networkConnectionMap <- MVar.readMVar mvar diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index 063524f..bcfeb7e 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -76,6 +76,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria NCon.changePartnerAddress ncToPartner clientHostaddress port connectionID SSem.signal $ ncHandlingIncomingMessage ncToPartner NC.sendResponse hdl Messages.Okay + NClient.sendNetworkMessage activeCons ncToPartner (Messages.AcknowledgePartnerAddress (ncOwnUserID ncToPartner) connectionID) 0 return () AcknowledgePartnerAddress userid connectionID -> do diff --git a/src/Networking/Tests.hs b/src/Networking/Tests.hs new file mode 100644 index 0000000..c83fb9f --- /dev/null +++ b/src/Networking/Tests.hs @@ -0,0 +1,54 @@ +module Networking.Tests where + +import Networking.Assert +import Networking.Buffer +import Networking.NetworkBuffer +import ProcessEnvironmentTypes + +test = testBuffer >> testNetworkBuffer + +testBuffer = do + newBuf <- newBuffer + writeBufferToList newBuf >>= assertEQ "1: Empty Buffer" [] + tryTakeBuffer newBuf >>= assertEQ "2: Nothing" Nothing + tryReadBuffer newBuf >>= assertEQ "3: Read Nothing" Nothing + writeBuffer newBuf 42 + writeBufferToList newBuf >>= assertEQ "4: One Element Buffer" [42] + cloneBuffer <- cloneBuffer newBuf + writeBufferToList newBuf >>= assertEQ "5: One Element in Clone" [42] + writeBuffer cloneBuffer 1337 + writeBufferToList cloneBuffer >>= assertEQ "6: 2 Elements in Clone" [42, 1337] + writeBufferToList newBuf >>= assertEQ "7: 2 Elements in Buffer" [42, 1337] + tryReadBuffer cloneBuffer >>= assertEQ "8: Try Read from Clone" (Just 42) + readBuffer cloneBuffer >>= assertEQ "9: Read from Clone" 42 + takeBuffer cloneBuffer >>= assertEQ "10: Take from Clone " 42 + tryTakeBuffer cloneBuffer >>= assertEQ "11: Try Take from Clone" (Just 1337) + writeBufferToList newBuf >>= assertEQ "12: 2 Elements in Buffer" [42, 1337] + writeBufferToList cloneBuffer >>= assertEQ "13: Empty Clone" [] + writeBuffer newBuf 1 + writeBufferToList newBuf >>= assertEQ "14: 3 Elements in Buffer" [42, 1337, 1] + writeBufferToList cloneBuffer >>= assertEQ "15: 1 Element in Clone" [1] + + +testNetworkBuffer = do + nb <- newNetworkBuffer + isAllAcknowledged nb >>= assertEQ "1: All acknowledged" True + write nb 42 + isAllAcknowledged nb >>= assertEQ "2: Not All acknowledged" False + serializeMinimal nb >>= assertEQ "3: Serial" ([42], 0, 1) + write nb 1337 + serializeMinimal nb >>= assertEQ "3: Serial" ([42, 1337], 0, 2) + tryGetAtNB nb 0 >>= assertEQ "4. 42" (Just 42) + tryGetAtNB nb 1 >>= assertEQ "5. 1337" (Just 1337) + tryTake nb >>= assertEQ "6. 42" (Just (42, 0)) + getNextOffset nb >>= assertEQ "7. 1" 1 + serializeMinimal nb >>= assertEQ "8: Serial" ([1337], 1, 2) + updateAcknowledgements nb 1 + isAllAcknowledged nb >>= assertEQ "9. All achnowledged" True + + + + + + + \ No newline at end of file diff --git a/testOftenHandoff.sh b/testOftenHandoff.sh new file mode 100644 index 0000000..90397fb --- /dev/null +++ b/testOftenHandoff.sh @@ -0,0 +1,3 @@ +for i in {1..1000}; do + bash testHandoff.sh; +done \ No newline at end of file From 1db174e5478d421f9d390cfe61ac65da26217941 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 23 Feb 2023 14:34:56 +0100 Subject: [PATCH 168/229] Seems stable again waitTillReadyToSend seems to remove the need for the disconnect. But This seems more like a stopgap solution --- .../bidirhandoff/BugsAssociatedWithThisTest | 1 - dev-examples/bidirhandoff/client.ldgvnw | 1 + .../bidirhandoff/clienthandoff.ldgvnw | 1 + dev-examples/bidirhandoff/server.ldgvnw | 1 + .../bidirhandoff/serverhandoff.ldgvnw | 1 + .../BugsAssociatedWithThisTest | 1 - .../bidirhandoffWithEnd/client.ldgvnw | 36 ------------- .../bidirhandoffWithEnd/clienthandoff.ldgvnw | 35 ------------- .../bidirhandoffWithEnd/server.ldgvnw | 35 ------------- .../bidirhandoffWithEnd/serverhandoff.ldgvnw | 34 ------------- src/Networking/Client.hs | 50 ++++++++++++++++++- 11 files changed, 52 insertions(+), 144 deletions(-) delete mode 100644 dev-examples/bidirhandoff/BugsAssociatedWithThisTest delete mode 100644 dev-examples/bidirhandoffWithEnd/BugsAssociatedWithThisTest delete mode 100644 dev-examples/bidirhandoffWithEnd/client.ldgvnw delete mode 100644 dev-examples/bidirhandoffWithEnd/clienthandoff.ldgvnw delete mode 100644 dev-examples/bidirhandoffWithEnd/server.ldgvnw delete mode 100644 dev-examples/bidirhandoffWithEnd/serverhandoff.ldgvnw diff --git a/dev-examples/bidirhandoff/BugsAssociatedWithThisTest b/dev-examples/bidirhandoff/BugsAssociatedWithThisTest deleted file mode 100644 index 40a0401..0000000 --- a/dev-examples/bidirhandoff/BugsAssociatedWithThisTest +++ /dev/null @@ -1 +0,0 @@ -In some cases when start order is server client clienthandoff serverhandoff communication might not end properly \ No newline at end of file diff --git a/dev-examples/bidirhandoff/client.ldgvnw b/dev-examples/bidirhandoff/client.ldgvnw index b846bf8..7e5607c 100644 --- a/dev-examples/bidirhandoff/client.ldgvnw +++ b/dev-examples/bidirhandoff/client.ldgvnw @@ -1,5 +1,6 @@ -- Simple example of Label-Dependent Session Types -- Interprets addition of two numbers +-- Expected return 1300 type SendInt : ! ~ssn = !Int. ?Int. !Int. ?Int. Unit type SendIntClient : ! ~ssn = !Int. ?Int. Unit diff --git a/dev-examples/bidirhandoff/clienthandoff.ldgvnw b/dev-examples/bidirhandoff/clienthandoff.ldgvnw index 7ddff05..aac53d3 100644 --- a/dev-examples/bidirhandoff/clienthandoff.ldgvnw +++ b/dev-examples/bidirhandoff/clienthandoff.ldgvnw @@ -1,5 +1,6 @@ -- Simple example of Label-Dependent Session Types -- Interprets addition of two numbers +-- Expected return 37 type SendInt : ! ~ssn = !Int. ?Int. !Int. ?Int. Unit type SendIntClient : ! ~ssn = !Int. ?Int. Unit diff --git a/dev-examples/bidirhandoff/server.ldgvnw b/dev-examples/bidirhandoff/server.ldgvnw index ef86806..77fe0cf 100644 --- a/dev-examples/bidirhandoff/server.ldgvnw +++ b/dev-examples/bidirhandoff/server.ldgvnw @@ -1,5 +1,6 @@ -- Simple example of Label-Dependent Session Types -- Interprets addition of two numbers +-- Expected return 1 type SendInt : ! ~ssn = !Int. ?Int. !Int. ?Int. Unit type SendIntClient : ! ~ssn = !Int. ?Int. Unit diff --git a/dev-examples/bidirhandoff/serverhandoff.ldgvnw b/dev-examples/bidirhandoff/serverhandoff.ldgvnw index 95dbe40..03fd2ad 100644 --- a/dev-examples/bidirhandoff/serverhandoff.ldgvnw +++ b/dev-examples/bidirhandoff/serverhandoff.ldgvnw @@ -1,5 +1,6 @@ -- Simple example of Label-Dependent Session Types -- Interprets addition of two numbers +-- Expected return 41 type SendInt : ! ~ssn = !Int. ?Int. !Int. ?Int. Unit type SendIntClient : ! ~ssn = !Int. ?Int. Unit diff --git a/dev-examples/bidirhandoffWithEnd/BugsAssociatedWithThisTest b/dev-examples/bidirhandoffWithEnd/BugsAssociatedWithThisTest deleted file mode 100644 index 40a0401..0000000 --- a/dev-examples/bidirhandoffWithEnd/BugsAssociatedWithThisTest +++ /dev/null @@ -1 +0,0 @@ -In some cases when start order is server client clienthandoff serverhandoff communication might not end properly \ No newline at end of file diff --git a/dev-examples/bidirhandoffWithEnd/client.ldgvnw b/dev-examples/bidirhandoffWithEnd/client.ldgvnw deleted file mode 100644 index cf01cf3..0000000 --- a/dev-examples/bidirhandoffWithEnd/client.ldgvnw +++ /dev/null @@ -1,36 +0,0 @@ --- Simple example of Label-Dependent Session Types --- Interprets addition of two numbers - -type SendInt : ! ~ssn = !Int. ?Int. !Int. ?Int. Unit -type SendIntClient : ! ~ssn = !Int. ?Int. Unit -type SendSendIntClient : ! ~ssn = !SendIntClient. Unit -type SendIntServer : ! ~ssn = ?Int. !Int. Unit -type SendSendIntServer : ! ~ssn = !SendIntServer. Unit - -val send2 (c: SendInt) = - let x = ((send c) 1) in - let = recv x in - let y = ((send x2) 41) in - let = recv y in - let y3 = end y2 in - (m + n) - -val add2 (c1: dualof SendInt) = - let = recv c1 in - let c22 = (send c2) 1300 in - let = recv c22 in - let c32 = (send c3) 37 in - let c4 = end c32 in - (m + n) - -val main : Int -val main = - -- let sock = (create 4343) in - let con = (connect 4343 SendInt "127.0.0.1" 4242 ) in -- This cannot be localhost, since this might break on containerized images - let x = ((send con) 1) in - let = recv x in - let con2 = (connect 4343 SendSendIntClient "127.0.0.1" 4340) in - let con22 = ((send con2) x2) in - let con23 = end con22 in - (n) - diff --git a/dev-examples/bidirhandoffWithEnd/clienthandoff.ldgvnw b/dev-examples/bidirhandoffWithEnd/clienthandoff.ldgvnw deleted file mode 100644 index 768682d..0000000 --- a/dev-examples/bidirhandoffWithEnd/clienthandoff.ldgvnw +++ /dev/null @@ -1,35 +0,0 @@ --- Simple example of Label-Dependent Session Types --- Interprets addition of two numbers - -type SendInt : ! ~ssn = !Int. ?Int. !Int. ?Int. Unit -type SendIntClient : ! ~ssn = !Int. ?Int. Unit -type SendSendIntClient : ! ~ssn = !SendIntClient. Unit -type SendIntServer : ! ~ssn = ?Int. !Int. Unit -type SendSendIntServer : ! ~ssn = !SendIntServer. Unit - -val send2 (c: SendInt) = - let x = ((send c) 1) in - let = recv x in - let y = ((send x2) 41) in - let = recv y in - let y3 = end y2 in - (m + n) - -val add2 (c1: dualof SendInt) = - let = recv c1 in - let c22 = (send c2) 1300 in - let = recv c22 in - let c32 = (send c3) 37 in - let c4 = end c32 in - (m + n) - -val main : Int -val main = - -- let sock = (create 4340) in - let con = (accept 4340 (dualof SendSendIntClient)) in -- This cannot be localhost, since this might break on containerized images - let = (recv con) in - let x = ((send talk) 41) in - let = recv x in - let con2 = end x2 in - (n) - diff --git a/dev-examples/bidirhandoffWithEnd/server.ldgvnw b/dev-examples/bidirhandoffWithEnd/server.ldgvnw deleted file mode 100644 index 16158da..0000000 --- a/dev-examples/bidirhandoffWithEnd/server.ldgvnw +++ /dev/null @@ -1,35 +0,0 @@ --- Simple example of Label-Dependent Session Types --- Interprets addition of two numbers - -type SendInt : ! ~ssn = !Int. ?Int. !Int. ?Int. Unit -type SendIntClient : ! ~ssn = !Int. ?Int. Unit -type SendSendIntClient : ! ~ssn = !SendIntClient. Unit -type SendIntServer : ! ~ssn = ?Int. !Int. Unit -type SendSendIntServer : ! ~ssn = !SendIntServer. Unit - -val send2 (c: SendInt) = - let x = ((send c) 1) in - let = recv x in - let y = ((send x2) 41) in - let = recv y in - let y3 = end y2 in - (m + n) - -val add2 (c1: dualof SendInt) = - let = recv c1 in - let c22 = (send c2) 1300 in - let = recv c22 in - let c32 = (send c3) 37 in - let c4 = end c32 in - (m + n) - -val main : Int -val main = - -- let sock = (create 4242) in - let con = (accept 4242 (dualof SendInt)) in - let = recv con in - let c22 = (send c2) 1300 in - let con2 = (accept 4242 (SendSendIntServer)) in - let con3 = ((send con2) c22) in - let con4 = end con3 in - (m) diff --git a/dev-examples/bidirhandoffWithEnd/serverhandoff.ldgvnw b/dev-examples/bidirhandoffWithEnd/serverhandoff.ldgvnw deleted file mode 100644 index 9fc0674..0000000 --- a/dev-examples/bidirhandoffWithEnd/serverhandoff.ldgvnw +++ /dev/null @@ -1,34 +0,0 @@ --- Simple example of Label-Dependent Session Types --- Interprets addition of two numbers - -type SendInt : ! ~ssn = !Int. ?Int. !Int. ?Int. Unit -type SendIntClient : ! ~ssn = !Int. ?Int. Unit -type SendSendIntClient : ! ~ssn = !SendIntClient. Unit -type SendIntServer : ! ~ssn = ?Int. !Int. Unit -type SendSendIntServer : ! ~ssn = !SendIntServer. Unit - -val send2 (c: SendInt) = - let x = ((send c) 1) in - let = recv x in - let y = ((send x2) 41) in - let = recv y in - let y3 = end y2 in - (m + n) - -val add2 (c1: dualof SendInt) = - let = recv c1 in - let c22 = (send c2) 1300 in - let = recv c22 in - let c32 = (send c3) 37 in - let c4 = end c32 in - (m + n) - -val main : Int -val main = - -- let sock = (create 4240) in - let con = (connect 4240 (dualof SendSendIntServer) "127.0.0.1" 4242) in - let = recv con in - let = recv talk in - let c22 = (send c2) 37 in - let con4 = end c22 in - (m) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 50e4abc..91754af 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -35,11 +35,13 @@ sendValue vchanconsmvar activeCons networkconnection val ownport resendOnError = connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of Connected hostname port _ _ _ -> do + waitTillReadyToSend val setRedirectRequests vchanconsmvar hostname port ownport val valcleaned <- serializeVChan val messagesCount <- NB.write (ncWrite networkconnection) valcleaned tryToSendNetworkMessage activeCons networkconnection hostname port (Messages.NewValue (ncOwnUserID networkconnection) messagesCount valcleaned) resendOnError Emulated {} -> do + waitTillReadyToSend val vchancons <- MVar.readMVar vchanconsmvar valCleaned <- serializeVChan val NB.write(ncWrite networkconnection) valCleaned @@ -56,6 +58,19 @@ sendValue vchanconsmvar activeCons networkconnection val ownport resendOnError = Config.traceNetIO "Error when sending message: This channel is disconnected" return False +waitTillReadyToSend :: Value -> IO () +waitTillReadyToSend input = do + ready <- channelReadyToSend input + unless ready $ threadDelay 5000 >> waitTillReadyToSend input + +channelReadyToSend :: Value -> IO Bool +channelReadyToSend = searchVChans handleChannel True (&&) + where + handleChannel :: Value -> IO Bool + handleChannel input = case input of + VChan nc used -> NB.isAllAcknowledged $ ncWrite nc + _ -> return True + sendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> Message -> Int -> IO Bool sendNetworkMessage activeCons networkconnection message resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection @@ -248,7 +263,7 @@ sendDisconnect ac mvar = do _ -> return True -} - +{- sendDisconnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> IO () sendDisconnect ac mvar = do networkConnectionMap <- MVar.readMVar mvar @@ -279,4 +294,35 @@ sendDisconnect ac mvar = do catch (sendNetworkMessage ac con (Messages.Disconnect $ ncOwnUserID con) 0) $ printConErr host port return True else return False - _ -> return True \ No newline at end of file + _ -> return True +-} + +sendDisconnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> IO () +sendDisconnect ac mvar = do + networkConnectionMap <- MVar.readMVar mvar + let allNetworkConnections = Map.elems networkConnectionMap + goodbyes <- doForall ac allNetworkConnections + unless goodbyes $ do + threadDelay 100000 + sendDisconnect ac mvar + where + doForall ac (x:xs) = do + xres <- sendDisconnectNetworkConnection ac x + rest <- doForall ac xs + return $ xres && rest + doForall ac [] = return True + sendDisconnectNetworkConnection :: NMC.ActiveConnections -> NetworkConnection Value -> IO Bool + sendDisconnectNetworkConnection ac con = do + let writeVals = ncWrite con + connectionState <- MVar.readMVar $ ncConnectionState con + -- unreadVals <- DC.unreadMessageStart writeVals + -- lengthVals <- DC.countMessages writeVals + -- Config.traceNetIO "Checking if everything is acknowledged" + -- NB.serialize writeVals >>= Config.traceNetIO . show + -- NB.isAllAcknowledged writeVals >>= Config.traceNetIO . show + + ret <- NB.isAllAcknowledged writeVals + unless ret $ do + serial <- NB.serialize writeVals + Config.traceNetIO $ show serial + return ret \ No newline at end of file From 7527e18038c7db60ed40a04a6b331a394526defd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 23 Feb 2023 15:38:33 +0100 Subject: [PATCH 169/229] Seems to be stable --- src/Networking/Client.hs | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 91754af..1da21a0 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -35,13 +35,13 @@ sendValue vchanconsmvar activeCons networkconnection val ownport resendOnError = connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of Connected hostname port _ _ _ -> do - waitTillReadyToSend val + --waitTillReadyToSend val setRedirectRequests vchanconsmvar hostname port ownport val valcleaned <- serializeVChan val messagesCount <- NB.write (ncWrite networkconnection) valcleaned tryToSendNetworkMessage activeCons networkconnection hostname port (Messages.NewValue (ncOwnUserID networkconnection) messagesCount valcleaned) resendOnError Emulated {} -> do - waitTillReadyToSend val + --waitTillReadyToSend val vchancons <- MVar.readMVar vchanconsmvar valCleaned <- serializeVChan val NB.write(ncWrite networkconnection) valCleaned @@ -320,9 +320,12 @@ sendDisconnect ac mvar = do -- Config.traceNetIO "Checking if everything is acknowledged" -- NB.serialize writeVals >>= Config.traceNetIO . show -- NB.isAllAcknowledged writeVals >>= Config.traceNetIO . show - - ret <- NB.isAllAcknowledged writeVals - unless ret $ do - serial <- NB.serialize writeVals - Config.traceNetIO $ show serial - return ret \ No newline at end of file + case connectionState of + Connected {} -> do + ret <- NB.isAllAcknowledged writeVals + unless ret $ do + serial <- NB.serialize writeVals + Config.traceNetIO $ show serial + return ret + _ -> return True + \ No newline at end of file From 907489e9deafebcf7b891cc4d9b85a89e609f422 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sun, 26 Feb 2023 12:16:15 +0100 Subject: [PATCH 170/229] Update client.ldgvnw --- dev-examples/add/client.ldgvnw | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/dev-examples/add/client.ldgvnw b/dev-examples/add/client.ldgvnw index 5fccada..e55430d 100644 --- a/dev-examples/add/client.ldgvnw +++ b/dev-examples/add/client.ldgvnw @@ -6,17 +6,14 @@ type SendInt : ! ~ssn = !Int. !Int. Unit val send2 (c: SendInt) = let x = ((send c) 1) in let y = ((send x) 42) in - -- let z = end y in () val add2 (c1: dualof SendInt) = let = recv c1 in let = recv c2 in - -- let c4 = end c3 in (m + n) val main : Unit val main = - -- let sock = (create 4343) in - let con = (connect 4343 SendInt "127.0.0.1" 4242 ) in -- This cannot be localhost, since this might break on containerized images + let con = (connect 4343 SendInt "127.0.0.1" 4242 ) in send2 con From fabb775c8aae33ce7ac177d354de8cb5ad41e83e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sun, 26 Feb 2023 12:38:38 +0100 Subject: [PATCH 171/229] Added new testcase Fails if server finished before handoff --- dev-examples/handoff6/client.ldgvnw | 24 ++++++++++++++++++++++++ dev-examples/handoff6/handoff.ldgvnw | 22 ++++++++++++++++++++++ dev-examples/handoff6/server.ldgvnw | 23 +++++++++++++++++++++++ testOftenHandoff6.sh | 3 +++ 4 files changed, 72 insertions(+) create mode 100644 dev-examples/handoff6/client.ldgvnw create mode 100644 dev-examples/handoff6/handoff.ldgvnw create mode 100644 dev-examples/handoff6/server.ldgvnw create mode 100644 testOftenHandoff6.sh diff --git a/dev-examples/handoff6/client.ldgvnw b/dev-examples/handoff6/client.ldgvnw new file mode 100644 index 0000000..6a147e5 --- /dev/null +++ b/dev-examples/handoff6/client.ldgvnw @@ -0,0 +1,24 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit +type EmptyConversation : ! ~ssn = Unit +type SendEmptyConversation : ! ~ssn = !EmptyConversation.Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let y = ((send x) 42) in + (y) + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val main : Unit +val main = + let con = (connect 4343 SendInt "127.0.0.1" 4242 ) in + let emptycon = send2 con in + let handoff = (accept 4343 SendEmptyConversation) in + (send handoff) emptycon + diff --git a/dev-examples/handoff6/handoff.ldgvnw b/dev-examples/handoff6/handoff.ldgvnw new file mode 100644 index 0000000..0b6860c --- /dev/null +++ b/dev-examples/handoff6/handoff.ldgvnw @@ -0,0 +1,22 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit +type EmptyConversation : ! ~ssn = Unit +type SendEmptyConversation : ! ~ssn = !EmptyConversation.Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let y = ((send x) 42) in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val main : Unit +val main = + let con = (connect 4444 (dualof SendEmptyConversation) "127.0.0.1" 4343 ) in + let = recv con in + (empty) diff --git a/dev-examples/handoff6/server.ldgvnw b/dev-examples/handoff6/server.ldgvnw new file mode 100644 index 0000000..fdb5e13 --- /dev/null +++ b/dev-examples/handoff6/server.ldgvnw @@ -0,0 +1,23 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let y = ((send x) 42) in + -- let z = end y in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + -- let c4 = end c3 in + (m + n) + + +val main : Int +val main = + -- let sock = (create 4242) in + let con = (accept 4242 (dualof SendInt)) in + add2 con diff --git a/testOftenHandoff6.sh b/testOftenHandoff6.sh new file mode 100644 index 0000000..0b70262 --- /dev/null +++ b/testOftenHandoff6.sh @@ -0,0 +1,3 @@ +for i in {1..2000}; do + clear; echo "$i Handoff6"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff6/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff6/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff6/client.ldgvnw & wait); +done \ No newline at end of file From 9cd85db37790779398ec2cf7a75544d9c075ca19 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sun, 26 Feb 2023 20:54:03 +0100 Subject: [PATCH 172/229] Readded Disconnect messages Disconnect messages are seemingly required for odd situations like in handoff6. This build seems to be stable with 1000 runs --- dev-examples/handoff6/client.ldgvnw | 3 +- src/Interpreter.hs | 2 ++ src/Networking/Client.hs | 43 +++++++++++++++-------------- src/Networking/NetworkConnection.hs | 14 +++++++--- src/Networking/Server.hs | 10 ++++++- testNWCount.sh | 1 + testNWCountHigh.sh | 3 +- 7 files changed, 49 insertions(+), 27 deletions(-) diff --git a/dev-examples/handoff6/client.ldgvnw b/dev-examples/handoff6/client.ldgvnw index 6a147e5..f13e3d3 100644 --- a/dev-examples/handoff6/client.ldgvnw +++ b/dev-examples/handoff6/client.ldgvnw @@ -20,5 +20,6 @@ val main = let con = (connect 4343 SendInt "127.0.0.1" 4242 ) in let emptycon = send2 con in let handoff = (accept 4343 SendEmptyConversation) in - (send handoff) emptycon + let concon = (send handoff) emptycon in + () diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 79922dd..64dc2a2 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -261,7 +261,9 @@ interpretApp _ (VSend v@(VChan cc usedmvar)) w = do (env, (sockets, vchanconnections, activeConnections)) <- ask socketsraw <- liftIO $ MVar.readMVar sockets let port = show $ head $ Map.keys socketsraw + C.traceNetIO $ "Trying to send: " ++ show w liftIO $ NClient.sendValue vchanconnections activeConnections cc w port (-1) + C.traceNetIO $ "Sent: " ++ show w -- Disable old VChan liftIO $ disableOldVChan v interpretApp e _ _ = throw $ ApplicationException e diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 1da21a0..6cf7ade 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -34,12 +34,6 @@ sendValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Valu sendValue vchanconsmvar activeCons networkconnection val ownport resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of - Connected hostname port _ _ _ -> do - --waitTillReadyToSend val - setRedirectRequests vchanconsmvar hostname port ownport val - valcleaned <- serializeVChan val - messagesCount <- NB.write (ncWrite networkconnection) valcleaned - tryToSendNetworkMessage activeCons networkconnection hostname port (Messages.NewValue (ncOwnUserID networkconnection) messagesCount valcleaned) resendOnError Emulated {} -> do --waitTillReadyToSend val vchancons <- MVar.readMVar vchanconsmvar @@ -54,9 +48,19 @@ sendValue vchanconsmvar activeCons networkconnection val ownport resendOnError = _ -> do Config.traceNetIO "Something went wrong when sending over a emulated connection" return False - _ -> do - Config.traceNetIO "Error when sending message: This channel is disconnected" - return False + _ -> do + let hostname = csHostname connectionstate + let port = csPort connectionstate + --waitTillReadyToSend val + setRedirectRequests vchanconsmvar hostname port ownport val + Config.traceNetIO $ "Redirected: " ++ show val + valcleaned <- serializeVChan val + Config.traceNetIO $ "Serialized: " ++ show val + messagesCount <- NB.write (ncWrite networkconnection) valcleaned + Config.traceNetIO $ "Wrote to Buffer: " ++ show val + result <- tryToSendNetworkMessage activeCons networkconnection hostname port (Messages.NewValue (ncOwnUserID networkconnection) messagesCount valcleaned) resendOnError + Config.traceNetIO $ "Sent message: " ++ show val + return result waitTillReadyToSend :: Value -> IO () waitTillReadyToSend input = do @@ -75,12 +79,11 @@ sendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> Messag sendNetworkMessage activeCons networkconnection message resendOnError = do connectionstate <- MVar.readMVar $ ncConnectionState networkconnection case connectionstate of - Connected hostname port _ _ _ -> do - tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError Emulated {} -> return True - _ -> do - Config.traceNetIO "Error when sending message: This channel is disconnected" - return False + _ -> do + let hostname = csHostname connectionstate + let port = csPort connectionstate + tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError tryToSendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> String -> String -> Message -> Int -> IO Bool tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError = do @@ -210,7 +213,9 @@ setRedirectRequests vchanconmvar newhost newport ownport = searchVChans (handleV MVar.putMVar vchanconmvar vchanconnections - Disconnected partConID ownConID confirmed -> Config.traceNetIO "Cannot set RedirectRequest for a disconnected channel" + Disconnected hostname partner partConID ownConID confirmed -> do + MVar.putMVar (ncConnectionState nc) oldconnectionstate + Config.traceNetIO "Cannot set RedirectRequest for a disconnected channel" ) Config.traceNetIO $ "Set RedirectRequest for " ++ ncPartnerUserID nc ++ " to " ++ newhost ++ ":" ++ newport return True @@ -321,11 +326,9 @@ sendDisconnect ac mvar = do -- NB.serialize writeVals >>= Config.traceNetIO . show -- NB.isAllAcknowledged writeVals >>= Config.traceNetIO . show case connectionState of - Connected {} -> do + Connected host port _ _ _ -> do ret <- NB.isAllAcknowledged writeVals - unless ret $ do - serial <- NB.serialize writeVals - Config.traceNetIO $ show serial - return ret + if ret then catch (sendNetworkMessage ac con (Messages.Disconnect $ ncOwnUserID con) $ -1) (\x -> printConErr host port x >> return True) else return False + -- return False _ -> return True \ No newline at end of file diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index ea273cf..4590f3b 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -10,7 +10,7 @@ data NetworkConnection a = NetworkConnection {ncRead :: NetworkBuffer a, ncWrite deriving Eq data ConnectionState = Connected {csHostname :: String, csPort :: String, csPartnerConnectionID :: String, csOwnConnectionID :: String, csConfirmedConnection :: Bool} - | Disconnected {csPartnerConnectionID :: String, csOwnConnectionID :: String, csConfirmedConnection :: Bool} + | Disconnected {csHostname :: String, csPort :: String, csPartnerConnectionID :: String, csOwnConnectionID :: String, csConfirmedConnection :: Bool} | Emulated {csPartnerConnectionID :: String, csOwnConnectionID :: String, csConfirmedConnection :: Bool} | RedirectRequest {csHostname :: String, csPort :: String, csRedirectHostname :: String, csRedirectPort :: String, csPartnerConnectionID :: String, csOwnConnectionID :: String, csConfirmedConnection :: Bool} -- Asks to redirect to this connection deriving (Eq, Show) @@ -30,7 +30,10 @@ createNetworkConnection (readList, readOffset, readLength) (writeList, writeOffs read <- deserializeMinimal (readList, readOffset, readLength) write <- deserializeMinimal (writeList, writeOffset, writeLength) ownConnectionID <- newRandomID - connectionstate <- MVar.newMVar $ Connected hostname port partnerConnectionID ownConnectionID False + connectionstate <- if port=="" then + MVar.newMVar $ Disconnected "" "" partnerConnectionID ownConnectionID True + else + MVar.newMVar $ Connected hostname port partnerConnectionID ownConnectionID False incomingMsg <- SSem.new 1 return $ NetworkConnection read write partnerID ownID connectionstate incomingMsg @@ -76,7 +79,10 @@ changePartnerAddress con hostname port partnerConnectionID = do disconnectFromPartner :: NetworkConnection a -> IO () disconnectFromPartner con = do oldConnectionState <- MVar.takeMVar $ ncConnectionState con - MVar.putMVar (ncConnectionState con) $ Disconnected (csPartnerConnectionID oldConnectionState) (csOwnConnectionID oldConnectionState) True + case oldConnectionState of + Emulated {} -> + MVar.putMVar (ncConnectionState con) $ Disconnected "" "" (csPartnerConnectionID oldConnectionState) (csOwnConnectionID oldConnectionState) True + _ -> MVar.putMVar (ncConnectionState con) $ Disconnected (csHostname oldConnectionState) (csPort oldConnectionState) (csPartnerConnectionID oldConnectionState) (csOwnConnectionID oldConnectionState) True isConnectionConfirmed :: NetworkConnection a -> IO Bool isConnectionConfirmed con = do @@ -89,7 +95,7 @@ confirmConnectionID con ownConnectionID = do if ownConnectionID == csOwnConnectionID conState then do newConState <- case conState of Connected host port part own conf -> return $ Connected host port part own True - Disconnected part own conf -> return $ Disconnected part own True + Disconnected host port part own conf -> return $ Disconnected host port part own True Emulated part own conf -> return $ Emulated part own True RedirectRequest host port rehost report part own conf -> return $ RedirectRequest host port rehost report part own True MVar.putMVar (ncConnectionState con) newConState diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index bcfeb7e..fec6859 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -84,9 +84,17 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria SSem.signal $ ncHandlingIncomingMessage ncToPartner if conConfirmed then NC.sendResponse hdl Messages.Okay else NC.sendResponse hdl Messages.Error Disconnect userid -> do + NC.sendResponse hdl Messages.Okay NCon.disconnectFromPartner ncToPartner SSem.signal $ ncHandlingIncomingMessage ncToPartner - NC.sendResponse hdl Messages.Okay + -- Config.traceNetIO "Trying to send AcknowledgeDisconnect" + -- NClient.sendNetworkMessage activeCons ncToPartner (Messages.AcknowledgeDisconnect $ ncOwnUserID ncToPartner) 0 + -- Config.traceNetIO "Sent AcknowledgeDisconnect" + return () + {-AcknowledgeDisconnect userid -> do + NCon.disconnectFromPartner ncToPartner + SSem.signal $ ncHandlingIncomingMessage ncToPartner + NC.sendResponse hdl Messages.Okay-} _ -> do serial <- NSerialize.serialize deserialmessages recievedNetLog message $ "Error unsupported networkmessage: "++ serial diff --git a/testNWCount.sh b/testNWCount.sh index 3522047..c4dceee 100644 --- a/testNWCount.sh +++ b/testNWCount.sh @@ -7,5 +7,6 @@ for i in {1..1000}; do clear; echo "$i Handoff3"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff3/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/client.ldgvnw & wait); clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/client.ldgvnw & wait); clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff5/handoff.ldgvnw & wait); + clear; echo "$i Handoff6"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff6/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff6/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff6/client.ldgvnw & wait); clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/client.ldgvnw & wait); done \ No newline at end of file diff --git a/testNWCountHigh.sh b/testNWCountHigh.sh index 52a4fc2..903813e 100644 --- a/testNWCountHigh.sh +++ b/testNWCountHigh.sh @@ -6,6 +6,7 @@ for i in {1..20000}; do clear; echo "$i Handoff2"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/client.ldgvnw & wait); clear; echo "$i Handoff3"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff3/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/client.ldgvnw & wait); clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/client.ldgvnw & wait); - clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff5/handoff.ldgvnw & wait); + clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff5/handoff.ldgvnw & wait); + clear; echo "$i Handoff6"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff6/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff6/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff6/client.ldgvnw & wait); clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/client.ldgvnw & wait); done \ No newline at end of file From 987fd0e00ad071edfcd32592adfeadfbd46781bd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 27 Feb 2023 10:03:19 +0100 Subject: [PATCH 173/229] Made disconnect faster Seems stable over 5K runs without issue --- src/Config.hs | 6 +++--- src/Interpreter.hs | 5 ++--- src/Networking/Client.hs | 8 +++++++- 3 files changed, 12 insertions(+), 7 deletions(-) diff --git a/src/Config.hs b/src/Config.hs index 46a2e22..80a6a6b 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -12,9 +12,9 @@ data DebugLevel = DebugNone | DebugNetwork | DebugAll deriving (Eq, Ord, Show) debugLevel :: DebugLevel ---debugLevel = DebugAll -debugLevel = DebugNetwork ---debugLevel = DebugNone +-- debugLevel = DebugAll +-- debugLevel = DebugNetwork +debugLevel = DebugNone trace :: String -> a -> a trace s a | debugLevel > DebugNetwork = D.trace s a diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 64dc2a2..98f51c7 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -75,11 +75,10 @@ interpret decls = do vchanconnections <- MVar.newMVar Map.empty activeConnections <- NC.createActiveConnections result <- R.runReaderT (interpretDecl decls) ([], (sockets, vchanconnections, activeConnections)) - C.traceNetIO "Finished interpreting" + putStrLn $ "Finished interpreting " ++ show result NClient.sendDisconnect activeConnections vchanconnections - C.traceNetIO "Sent client disconnects" + putStrLn $ "Sent client disconnects " ++ show result NC.sayGoodbye activeConnections - C.traceNetIO "Done" return result interpretDecl :: [Decl] -> InterpretM Value diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 6cf7ade..eccbfb3 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -19,6 +19,7 @@ import qualified Networking.Serialize as NSerialize import Control.Monad import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC import qualified Control.Concurrent.SSem as SSem +import qualified Networking.NetworkConnection as NCon newtype ClientException = NoIntroductionException String @@ -328,7 +329,12 @@ sendDisconnect ac mvar = do case connectionState of Connected host port _ _ _ -> do ret <- NB.isAllAcknowledged writeVals - if ret then catch (sendNetworkMessage ac con (Messages.Disconnect $ ncOwnUserID con) $ -1) (\x -> printConErr host port x >> return True) else return False + if ret then do + sent <- catch (sendNetworkMessage ac con (Messages.Disconnect $ ncOwnUserID con) $ -1) (\x -> printConErr host port x >> return True) + when sent $ NCon.disconnectFromPartner con -- This should cause a small speedup + return sent + else + return False -- return False _ -> return True \ No newline at end of file From 5d71baa6920c7a085f2835bacf4a4782fe075d3a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 2 Mar 2023 10:43:41 +0100 Subject: [PATCH 174/229] Removed unnecessary code --- src/Interpreter.hs | 2 -- src/Networking/Client.hs | 76 ---------------------------------------- 2 files changed, 78 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 98f51c7..e9fd427 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -75,9 +75,7 @@ interpret decls = do vchanconnections <- MVar.newMVar Map.empty activeConnections <- NC.createActiveConnections result <- R.runReaderT (interpretDecl decls) ([], (sockets, vchanconnections, activeConnections)) - putStrLn $ "Finished interpreting " ++ show result NClient.sendDisconnect activeConnections vchanconnections - putStrLn $ "Sent client disconnects " ++ show result NC.sayGoodbye activeConnections return result diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index eccbfb3..6e9e298 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -232,7 +232,6 @@ serializeVChan = modifyVChans handleVChan return $ VChanSerial (r, ro, rl) (w, wo, wl) pid oid (h, p, partConID) _ -> return input -{- sendDisconnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> IO () sendDisconnect ac mvar = do networkConnectionMap <- MVar.readMVar mvar @@ -251,81 +250,6 @@ sendDisconnect ac mvar = do sendDisconnectNetworkConnection ac con = do let writeVals = ncWrite con connectionState <- MVar.readMVar $ ncConnectionState con - -- unreadVals <- DC.unreadMessageStart writeVals - -- lengthVals <- DC.countMessages writeVals - -- Config.traceNetIO "Checking if everything is acknowledged" - -- NB.serialize writeVals >>= Config.traceNetIO . show - -- NB.isAllAcknowledged writeVals >>= Config.traceNetIO . show - case connectionState of - -- Connected host port _ _ _ -> if unreadVals >= lengthVals then do - Connected host port _ _ _ -> do - count <- NB.getNextOffset (ncRead con) - if count == 0 then return True else catch (sendNetworkMessage ac con (Messages.AcknowledgeValue (ncOwnUserID con) $ count-1) 0) $ printConErr host port - -- ret <- NB.isAllAcknowledged writeVals - -- writeValsSer <- NB.serialize writeVals - -- Config.traceNetIO $ show writeValsSer ++ "\n " ++ if ret then "All acknowledged" else "Not completely acknowledged" - -- return ret - NB.isAllAcknowledged writeVals - _ -> return True --} - -{- -sendDisconnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> IO () -sendDisconnect ac mvar = do - networkConnectionMap <- MVar.readMVar mvar - let allNetworkConnections = Map.elems networkConnectionMap - goodbyes <- doForall ac allNetworkConnections - unless goodbyes $ do - threadDelay 100000 - sendDisconnect ac mvar - where - doForall ac (x:xs) = do - xres <- sendDisconnectNetworkConnection ac x - rest <- doForall ac xs - return $ xres && rest - doForall ac [] = return True - sendDisconnectNetworkConnection :: NMC.ActiveConnections -> NetworkConnection Value -> IO Bool - sendDisconnectNetworkConnection ac con = do - let writeVals = ncWrite con - connectionState <- MVar.readMVar $ ncConnectionState con - -- unreadVals <- DC.unreadMessageStart writeVals - -- lengthVals <- DC.countMessages writeVals - -- Config.traceNetIO "Checking if everything is acknowledged" - -- NB.serialize writeVals >>= Config.traceNetIO . show - -- NB.isAllAcknowledged writeVals >>= Config.traceNetIO . show - allAcknowledged <- NB.isAllAcknowledged writeVals - case connectionState of - -- Connected host port _ _ _ -> if unreadVals >= lengthVals then do - Connected host port _ _ _ -> if allAcknowledged then do - - catch (sendNetworkMessage ac con (Messages.Disconnect $ ncOwnUserID con) 0) $ printConErr host port - return True else return False - _ -> return True --} - -sendDisconnect :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> IO () -sendDisconnect ac mvar = do - networkConnectionMap <- MVar.readMVar mvar - let allNetworkConnections = Map.elems networkConnectionMap - goodbyes <- doForall ac allNetworkConnections - unless goodbyes $ do - threadDelay 100000 - sendDisconnect ac mvar - where - doForall ac (x:xs) = do - xres <- sendDisconnectNetworkConnection ac x - rest <- doForall ac xs - return $ xres && rest - doForall ac [] = return True - sendDisconnectNetworkConnection :: NMC.ActiveConnections -> NetworkConnection Value -> IO Bool - sendDisconnectNetworkConnection ac con = do - let writeVals = ncWrite con - connectionState <- MVar.readMVar $ ncConnectionState con - -- unreadVals <- DC.unreadMessageStart writeVals - -- lengthVals <- DC.countMessages writeVals - -- Config.traceNetIO "Checking if everything is acknowledged" - -- NB.serialize writeVals >>= Config.traceNetIO . show - -- NB.isAllAcknowledged writeVals >>= Config.traceNetIO . show case connectionState of Connected host port _ _ _ -> do ret <- NB.isAllAcknowledged writeVals From ad78c7d2e4957fca94386a085bffc55a609e5fa1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 2 Mar 2023 10:54:20 +0100 Subject: [PATCH 175/229] Sorted imports --- src/Networking/Client.hs | 27 ++++++++-------- src/Networking/NetworkBuffer.hs | 6 ++-- src/Networking/NetworkConnection.hs | 2 +- src/Networking/NetworkingMethod/Fast.hs | 23 +++++++------ .../NetworkingMethodCommon.hs | 6 ++-- src/Networking/NetworkingMethod/Stateless.hs | 22 ++++++------- src/Networking/Serialize.hs | 11 +++---- src/Networking/Server.hs | 32 ++++++++----------- src/Networking/Tests.hs | 4 ++- src/ValueParsing/ValueGrammar.y | 10 +++--- 10 files changed, 67 insertions(+), 76 deletions(-) diff --git a/src/Networking/Client.hs b/src/Networking/Client.hs index 6e9e298..7f5933e 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Client.hs @@ -2,25 +2,24 @@ module Networking.Client where -import qualified Config -import ProcessEnvironmentTypes -import Networking.Messages -import qualified Control.Concurrent.MVar as MVar -import qualified Networking.NetworkBuffer as NB -import qualified Networking.Messages as Messages -import qualified Networking.RandomID as RandomID -import qualified Data.Map as Map import Control.Concurrent import Control.Exception -import qualified Syntax -import qualified Networking.Common as NC -import Networking.NetworkConnection -import qualified Networking.Serialize as NSerialize import Control.Monad -import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC +import Networking.Messages +import Networking.NetworkConnection +import ProcessEnvironmentTypes +import qualified Config +import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.SSem as SSem +import qualified Data.Map as Map +import qualified Networking.Common as NC +import qualified Networking.Messages as Messages +import qualified Networking.NetworkBuffer as NB import qualified Networking.NetworkConnection as NCon - +import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC +import qualified Networking.RandomID as RandomID +import qualified Networking.Serialize as NSerialize +import qualified Syntax newtype ClientException = NoIntroductionException String deriving Eq diff --git a/src/Networking/NetworkBuffer.hs b/src/Networking/NetworkBuffer.hs index 16fac1e..64451f0 100644 --- a/src/Networking/NetworkBuffer.hs +++ b/src/Networking/NetworkBuffer.hs @@ -2,13 +2,13 @@ module Networking.NetworkBuffer where -import Networking.Buffer import Control.Concurrent.MVar import Control.Exception -import Data.Functor -import qualified Data.Maybe import Control.Monad +import Data.Functor +import Networking.Buffer import qualified Control.Concurrent.SSem as SSem +import qualified Data.Maybe data NetworkBuffer a = NetworkBuffer {buffer :: Buffer a, bufferOffset :: MVar Int, bufferAllMessagesLength :: MVar Int, working :: SSem.SSem} deriving Eq diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index 4590f3b..e0039a8 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -2,9 +2,9 @@ module Networking.NetworkConnection where import Networking.NetworkBuffer import Networking.RandomID -import qualified Data.Map as Map import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.SSem as SSem +import qualified Data.Map as Map data NetworkConnection a = NetworkConnection {ncRead :: NetworkBuffer a, ncWrite :: NetworkBuffer a, ncPartnerUserID :: String, ncOwnUserID :: String, ncConnectionState :: MVar.MVar ConnectionState, ncHandlingIncomingMessage :: SSem.SSem} deriving Eq diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index 9f80889..08ff779 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -1,24 +1,23 @@ module Networking.NetworkingMethod.Fast where -import Networking.NetworkingMethod.NetworkingMethodCommon -import Network.Socket -import GHC.IO.Handle -import qualified Control.Concurrent.MVar as MVar -import qualified Control.Concurrent.Chan as Chan -import qualified Data.Map as Map import Control.Concurrent -import Control.Monad import Control.Exception - +import Control.Monad +import GHC.IO.Handle +import Network.Socket import Networking.Messages import Networking.NetworkConnection +import Networking.NetworkingMethod.NetworkingMethodCommon import Networking.RandomID -import qualified Syntax -import qualified ValueParsing.ValueGrammar as VG -import qualified Config -import qualified Networking.NetworkingMethod.Stateless as Stateless import ProcessEnvironmentTypes +import qualified Config +import qualified Control.Concurrent.Chan as Chan +import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.SSem as SSem +import qualified Data.Map as Map +import qualified Networking.NetworkingMethod.Stateless as Stateless +import qualified Syntax +import qualified ValueParsing.ValueGrammar as VG type ResponseMapMVar = MVar.MVar (Map.Map String (String, Response)) diff --git a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs index c51e3f7..4d151a4 100644 --- a/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs +++ b/src/Networking/NetworkingMethod/NetworkingMethodCommon.hs @@ -1,12 +1,12 @@ module Networking.NetworkingMethod.NetworkingMethodCommon where import GHC.IO.Handle +import Network.Socket +import Networking.Messages import qualified Control.Concurrent.Chan as Chan import qualified Control.Concurrent.MVar as MVar -import qualified Data.Map as Map -import Networking.Messages import qualified Control.Concurrent.SSem as SSem -import Network.Socket +import qualified Data.Map as Map -- type ActiveConnections = ActiveConnectionsStateless diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index 02cdad0..73d7547 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -1,24 +1,22 @@ module Networking.NetworkingMethod.Stateless where -import Networking.NetworkingMethod.NetworkingMethodCommon - -import Network.Socket -import GHC.IO.Handle -import System.IO -import qualified Control.Concurrent.MVar as MVar -import qualified Data.Map as Map import Control.Concurrent -import Control.Monad import Control.Exception - +import Control.Monad +import GHC.IO.Handle +import Network.Socket import Networking.Messages import Networking.NetworkConnection +import Networking.NetworkingMethod.NetworkingMethodCommon import ProcessEnvironmentTypes -import qualified Networking.Serialize as NSerialize -import qualified ValueParsing.ValueTokens as VT -import qualified ValueParsing.ValueGrammar as VG +import System.IO import qualified Config +import qualified Control.Concurrent.MVar as MVar +import qualified Data.Map as Map +import qualified Networking.Serialize as NSerialize import qualified Syntax +import qualified ValueParsing.ValueGrammar as VG +import qualified ValueParsing.ValueTokens as VT type ConnectionHandler = ActiveConnectionsStateless -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> Conversation -> String -> String -> Message -> IO () diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index 92a9d5c..cc2e53c 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -4,16 +4,13 @@ module Networking.Serialize where import Control.Concurrent.Chan as Chan -import qualified Control.Concurrent.MVar as MVar -import Syntax -import Kinds -import Data.Set import Control.Exception -import ProcessEnvironmentTypes +import Data.Set +import Kinds import Networking.Messages -import qualified Networking.NetworkBuffer as NB +import ProcessEnvironmentTypes +import Syntax import qualified Networking.NetworkConnection as NCon -import qualified Data.Maybe newtype SerializationException = UnserializableException String deriving Eq diff --git a/src/Networking/Server.hs b/src/Networking/Server.hs index fec6859..1ba2c3e 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Server.hs @@ -2,31 +2,27 @@ {-# HLINT ignore "Redundant return" #-} module Networking.Server where -import qualified Control.Concurrent.MVar as MVar -import qualified Data.Map as Map -import qualified Data.Maybe -import Network.Socket import Control.Concurrent - +import Control.Monad +import Network.Socket import Networking.Messages -import qualified Networking.Common as NC -import qualified Networking.Serialize as NSerialize -import ProcessEnvironmentTypes -import qualified Syntax - -import qualified Networking.RandomID as RandomID -import qualified Networking.Messages as Messages -import qualified Networking.Client as NClient - import Networking.NetworkConnection +import ProcessEnvironmentTypes import qualified Config -import qualified Networking.NetworkConnection as NCon -import Control.Monad - -import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC +import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.SSem as SSem import qualified Data.Bifunctor +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Networking.Client as NClient +import qualified Networking.Common as NC +import qualified Networking.Messages as Messages import qualified Networking.NetworkBuffer as NB +import qualified Networking.NetworkConnection as NCon +import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC +import qualified Networking.RandomID as RandomID +import qualified Networking.Serialize as NSerialize +import qualified Syntax handleClient :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> MVar.MVar [(String, (Syntax.Type, Syntax.Type))] -> (Socket, SockAddr) -> NC.ConversationOrHandle -> String -> String -> Message -> IO () handleClient activeCons mvar clientlist clientsocket hdl ownport message deserialmessages = do diff --git a/src/Networking/Tests.hs b/src/Networking/Tests.hs index c83fb9f..d9ccca6 100644 --- a/src/Networking/Tests.hs +++ b/src/Networking/Tests.hs @@ -3,10 +3,11 @@ module Networking.Tests where import Networking.Assert import Networking.Buffer import Networking.NetworkBuffer -import ProcessEnvironmentTypes +test :: IO () test = testBuffer >> testNetworkBuffer +testBuffer :: IO () testBuffer = do newBuf <- newBuffer writeBufferToList newBuf >>= assertEQ "1: Empty Buffer" [] @@ -30,6 +31,7 @@ testBuffer = do writeBufferToList cloneBuffer >>= assertEQ "15: 1 Element in Clone" [1] +testNetworkBuffer :: IO () testNetworkBuffer = do nb <- newNetworkBuffer isAllAcknowledged nb >>= assertEQ "1: All acknowledged" True diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 3e3e5a6..f6190dc 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -2,15 +2,15 @@ module ValueParsing.ValueGrammar (parseValues, parseMessages, parseResponses, parseConversation) where import Control.Monad -import qualified Data.List as List -import qualified Data.Set as Set - import Kinds -import Syntax +import Networking.Messages import ProcessEnvironmentTypes +import Syntax import ValueParsing.ValueTokens (T(..)) +import qualified Data.List as List +import qualified Data.Set as Set import qualified ValueParsing.ValueTokens as T -import Networking.Messages + } %monad { T.Alex } From c53ca1b68de78277d07e9fccffe226b4a8c6d25e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 2 Mar 2023 11:01:17 +0100 Subject: [PATCH 176/229] Renamed Client and Server to something more appropriate --- ldgv.cabal | 4 ++-- src/Interpreter.hs | 18 +++++++++--------- src/Networking/{Server.hs => Incoming.hs} | 16 ++++++++-------- src/Networking/{Client.hs => Outgoing.hs} | 2 +- 4 files changed, 20 insertions(+), 20 deletions(-) rename src/Networking/{Server.hs => Incoming.hs} (93%) rename src/Networking/{Client.hs => Outgoing.hs} (99%) diff --git a/ldgv.cabal b/ldgv.cabal index de9cc91..b1bf886 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -68,17 +68,17 @@ library Kinds Networking.Assert Networking.Buffer - Networking.Client Networking.Common + Networking.Incoming Networking.Messages Networking.NetworkBuffer Networking.NetworkConnection Networking.NetworkingMethod.Fast Networking.NetworkingMethod.NetworkingMethodCommon Networking.NetworkingMethod.Stateless + Networking.Outgoing Networking.RandomID Networking.Serialize - Networking.Server Networking.Tests Parsing Parsing.Grammar diff --git a/src/Interpreter.hs b/src/Interpreter.hs index e9fd427..53c1263 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -23,8 +23,8 @@ import Control.Exception import Kinds (Multiplicity(..)) import qualified Networking.Common as NC -import qualified Networking.Client as NClient -import qualified Networking.Server as NS +import qualified Networking.Outgoing as NO +import qualified Networking.Incoming as NI import Control.Concurrent @@ -75,7 +75,7 @@ interpret decls = do vchanconnections <- MVar.newMVar Map.empty activeConnections <- NC.createActiveConnections result <- R.runReaderT (interpretDecl decls) ([], (sockets, vchanconnections, activeConnections)) - NClient.sendDisconnect activeConnections vchanconnections + NO.sendDisconnect activeConnections vchanconnections NC.sayGoodbye activeConnections return result @@ -172,7 +172,7 @@ eval = \case (env, (sockets, vchanconnections, activeConnections)) <- ask socketsraw <- liftIO $ MVar.readMVar sockets let port = show $ head $ Map.keys socketsraw - val <- liftIO $ NS.recieveValue vchanconnections activeConnections ci port + val <- liftIO $ NI.recieveValue vchanconnections activeConnections ci port liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e -- Disable the old channel and get a new one @@ -184,12 +184,12 @@ eval = \case case val of VInt port -> do (env, (sockets, vchanconnections, activeConnections)) <- ask - (clientlist, ownport) <- liftIO $ NC.acceptConversations activeConnections NS.handleClient port sockets vchanconnections + (clientlist, ownport) <- liftIO $ NC.acceptConversations activeConnections NI.handleClient port sockets vchanconnections t <- case tname of TName _ s -> maybe (throw $ LookupException s) (\(VType t) -> return t) (lookup s env) _ -> return tname - newuser <- liftIO $ NS.findFittingClient clientlist (tname, t) + newuser <- liftIO $ NI.findFittingClient clientlist (tname, t) networkconnectionmap <- liftIO $ MVar.readMVar vchanconnections case Map.lookup newuser networkconnectionmap of Nothing -> throw $ CommunicationPartnerNotFoundException newuser @@ -204,7 +204,7 @@ eval = \case case val of VInt port -> do (env, (sockets, vchanconnections, activeConnections)) <- ask - (chan, ownport) <- liftIO $ NC.acceptConversations activeConnections NS.handleClient port sockets vchanconnections + (chan, ownport) <- liftIO $ NC.acceptConversations activeConnections NI.handleClient port sockets vchanconnections addressVal <- interpret' e1 case addressVal of VString address -> do @@ -215,7 +215,7 @@ eval = \case TName _ s -> maybe (throw $ LookupException s) (\(VType t) -> return t) (lookup s env) _ -> return tname - liftIO $ NClient.initialConnect activeConnections vchanconnections address (show port) ownport (tname, t) + liftIO $ NO.initialConnect activeConnections vchanconnections address (show port) ownport (tname, t) _ -> throw $ NotAnExpectedValueException "VInt" portVal _ -> throw $ NotAnExpectedValueException "VString" addressVal _ -> throw $ NotAnExpectedValueException "VInt" val @@ -259,7 +259,7 @@ interpretApp _ (VSend v@(VChan cc usedmvar)) w = do socketsraw <- liftIO $ MVar.readMVar sockets let port = show $ head $ Map.keys socketsraw C.traceNetIO $ "Trying to send: " ++ show w - liftIO $ NClient.sendValue vchanconnections activeConnections cc w port (-1) + liftIO $ NO.sendValue vchanconnections activeConnections cc w port (-1) C.traceNetIO $ "Sent: " ++ show w -- Disable old VChan liftIO $ disableOldVChan v diff --git a/src/Networking/Server.hs b/src/Networking/Incoming.hs similarity index 93% rename from src/Networking/Server.hs rename to src/Networking/Incoming.hs index 1ba2c3e..643b9d3 100644 --- a/src/Networking/Server.hs +++ b/src/Networking/Incoming.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Redundant return" #-} -module Networking.Server where +module Networking.Incoming where import Control.Concurrent import Control.Monad @@ -14,12 +14,12 @@ import qualified Control.Concurrent.SSem as SSem import qualified Data.Bifunctor import qualified Data.Map as Map import qualified Data.Maybe -import qualified Networking.Client as NClient import qualified Networking.Common as NC import qualified Networking.Messages as Messages import qualified Networking.NetworkBuffer as NB import qualified Networking.NetworkConnection as NCon import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC +import qualified Networking.Outgoing as NO import qualified Networking.RandomID as RandomID import qualified Networking.Serialize as NSerialize import qualified Syntax @@ -60,7 +60,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria SSem.signal $ ncHandlingIncomingMessage ncToPartner NC.sendResponse hdl Messages.Okay mbyval <- NB.tryGetAtNB (NCon.ncWrite ncToPartner) count - Data.Maybe.maybe (return False) (\val -> NClient.sendNetworkMessage activeCons ncToPartner (Messages.NewValue (ncOwnUserID ncToPartner) count val) 0) mbyval + Data.Maybe.maybe (return False) (\val -> NO.sendNetworkMessage activeCons ncToPartner (Messages.NewValue (ncOwnUserID ncToPartner) count val) 0) mbyval return () AcknowledgeValue userid count -> do NC.sendResponse hdl Messages.Okay -- This okay is needed here to fix a race-condition with disconnects being faster than the okay @@ -73,7 +73,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria SSem.signal $ ncHandlingIncomingMessage ncToPartner NC.sendResponse hdl Messages.Okay - NClient.sendNetworkMessage activeCons ncToPartner (Messages.AcknowledgePartnerAddress (ncOwnUserID ncToPartner) connectionID) 0 + NO.sendNetworkMessage activeCons ncToPartner (Messages.AcknowledgePartnerAddress (ncOwnUserID ncToPartner) connectionID) 0 return () AcknowledgePartnerAddress userid connectionID -> do conConfirmed <- NCon.confirmConnectionID ncToPartner connectionID @@ -84,7 +84,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria NCon.disconnectFromPartner ncToPartner SSem.signal $ ncHandlingIncomingMessage ncToPartner -- Config.traceNetIO "Trying to send AcknowledgeDisconnect" - -- NClient.sendNetworkMessage activeCons ncToPartner (Messages.AcknowledgeDisconnect $ ncOwnUserID ncToPartner) 0 + -- NO.sendNetworkMessage activeCons ncToPartner (Messages.AcknowledgeDisconnect $ ncOwnUserID ncToPartner) 0 -- Config.traceNetIO "Sent AcknowledgeDisconnect" return () {-AcknowledgeDisconnect userid -> do @@ -164,7 +164,7 @@ contactNewPeers activeCons ownport = searchVChans (handleVChan activeCons ownpor Emulated {} -> return True _ -> do if csConfirmedConnection connectionState then return True else do - NClient.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) 0 + NO.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) 0 return False _ -> return True @@ -229,7 +229,7 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do -- msgCount <- DC.unreadMessageStart $ ncRead networkconnection connectionState <- MVar.readMVar $ ncConnectionState networkconnection case connectionState of - Connected {} -> NClient.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (ncOwnUserID networkconnection) $ snd unclean) $ -1 + Connected {} -> NO.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (ncOwnUserID networkconnection) $ snd unclean) $ -1 Emulated {} -> do vchancons <- MVar.readMVar vchanconsvar let ownid = ncOwnUserID networkconnection @@ -247,7 +247,7 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do msgCount <- NB.getNextOffset $ ncRead networkconnection connectionState <- MVar.readMVar $ ncConnectionState networkconnection case connectionState of - Connected {} -> NClient.sendNetworkMessage activeCons networkconnection (Messages.RequestValue (ncOwnUserID networkconnection) msgCount) 0 + Connected {} -> NO.sendNetworkMessage activeCons networkconnection (Messages.RequestValue (ncOwnUserID networkconnection) msgCount) 0 _ -> return True recieveValueInternal 100 vchanconsvar activeCons networkconnection ownport else do diff --git a/src/Networking/Client.hs b/src/Networking/Outgoing.hs similarity index 99% rename from src/Networking/Client.hs rename to src/Networking/Outgoing.hs index 7f5933e..073ff2a 100644 --- a/src/Networking/Client.hs +++ b/src/Networking/Outgoing.hs @@ -1,6 +1,6 @@ {-# LANGUAGE LambdaCase #-} -module Networking.Client where +module Networking.Outgoing where import Control.Concurrent import Control.Exception From 2a665b403cd2579ec80398ef6bcb029cf479ac51 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 2 Mar 2023 11:42:54 +0100 Subject: [PATCH 177/229] Fixed a few warnings --- exe/Main.hs | 3 --- src/Interpreter.hs | 2 ++ src/Networking/Common.hs | 2 ++ src/Networking/NetworkingMethod/Fast.hs | 8 ++++++++ src/Networking/Tests.hs | 4 ++-- src/ValueParsing/ValueTokens.x | 25 ------------------------- 6 files changed, 14 insertions(+), 30 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index def4002..91cf169 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -2,7 +2,6 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} module Main (main) where @@ -10,7 +9,6 @@ module Main (main) where import Control.Applicative import Control.Monad import Control.Monad.Reader -import Control.Concurrent import Data.ByteString.Builder import Data.Foldable import Data.Maybe @@ -26,7 +24,6 @@ import Parsing import qualified C.Compile as C import qualified C.Generate as C import qualified Interpreter as I -import qualified ProcessEnvironment as P import qualified ProcessEnvironmentTypes as P import qualified Syntax import qualified Typechecker as T diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 53c1263..c70297c 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -1,3 +1,5 @@ + +{-# OPTIONS_GHC -Wno-overlapping-patterns#-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 802a4fa..1e78d31 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-missing-signatures #-} + module Networking.Common where -- import qualified Networking.NetworkingMethod.Stateless as NetMethod diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index 08ff779..8ed2f32 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -39,6 +39,14 @@ conversationHandler handle = do sem <- SSem.new 1 conversationHandlerChangeHandle handle chan mvar sem +conversationHandlerChangeHandle :: Stateless.Conversation + -> Chan (ConversationID, (String, Message)) + -> MVar (Map.Map ConversationID (String, Response)) + -> e + -> IO + (Stateless.Conversation, MVar Bool, + Chan (ConversationID, (String, Message)), + MVar (Map.Map ConversationID (String, Response)), e) conversationHandlerChangeHandle handle chan mvar sem = do isClosed <- MVar.newEmptyMVar MVar.putMVar isClosed False diff --git a/src/Networking/Tests.hs b/src/Networking/Tests.hs index d9ccca6..fcca97c 100644 --- a/src/Networking/Tests.hs +++ b/src/Networking/Tests.hs @@ -10,7 +10,7 @@ test = testBuffer >> testNetworkBuffer testBuffer :: IO () testBuffer = do newBuf <- newBuffer - writeBufferToList newBuf >>= assertEQ "1: Empty Buffer" [] + writeBufferToList newBuf >>= assertEQ "1: Empty Buffer" ([] :: [Integer]) tryTakeBuffer newBuf >>= assertEQ "2: Nothing" Nothing tryReadBuffer newBuf >>= assertEQ "3: Read Nothing" Nothing writeBuffer newBuf 42 @@ -35,7 +35,7 @@ testNetworkBuffer :: IO () testNetworkBuffer = do nb <- newNetworkBuffer isAllAcknowledged nb >>= assertEQ "1: All acknowledged" True - write nb 42 + write nb (42 :: Integer) isAllAcknowledged nb >>= assertEQ "2: Not All acknowledged" False serializeMinimal nb >>= assertEQ "3: Serial" ([42], 0, 1) write nb 1337 diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index ef2b296..98c3168 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -14,8 +14,6 @@ module ValueParsing.ValueTokens , scanner ) where -import Kinds -import Text.Read (readMaybe) } %wrapper "monad" @@ -307,29 +305,6 @@ tok' f (pos@(AlexPn _ line column), _, _, inp) len = do ] Right tok -> pure $ T pos tok -{- -tokKind :: AlexAction T -tokKind = tok' \k -> - maybe (Left $ "invalid kind " ++ k) (Right . Kind) - $ readMaybe - $ ('K':) -- Subsitutes the initial '~' with 'K' - $ tail k - - -} - --- runAlexScan :: String -> Either ParseError AlexUserState -{-scanner str = runAlex str $ do - let loop i = do tok <- alexMonadScan - if (tokVal tok) == EOF then return i - else do let i' = i+1 in i' `seq` loop i' - loop 0-} - -{-scanner str = runAlex str $ do - let loop i = do tok <- alexMonadScan; - if (tokVal tok) == EOF - then return i - else do loop $! (i+1) - loop 0-} scanner str = runAlex str $ do let loop i = do tok <- alexMonadScan; From 995b3ec315f734b528b1729ec7e65b6e86c15a16 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 2 Mar 2023 13:13:20 +0100 Subject: [PATCH 178/229] Cleaned up ValueTokens.x --- src/ValueParsing/ValueTokens.x | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index 98c3168..b93cc61 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -306,15 +306,11 @@ tok' f (pos@(AlexPn _ line column), _, _, inp) len = do Right tok -> pure $ T pos tok -scanner str = runAlex str $ do - let loop i = do tok <- alexMonadScan; - if (tokVal tok) == EOF - then return i - else do loop $! (i++[(tokVal tok)]) - loop [] - +scanner str = runAlex str $ loop [] + where + loop i = do + tok <- alexMonadScan + if (tokVal tok) == EOF then return i else loop $! (i++[(tokVal tok)]) ignoreArgument a b = a } - --- https://gist.github.com/m1dnight/126d6b500175c2c286e3804584e5c4ce \ No newline at end of file From 2a84bcdc8a3e564c8f4a1d0b35d30ab58b701f06 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 2 Mar 2023 13:33:18 +0100 Subject: [PATCH 179/229] Update CPS.hs --- src/C/CPS.hs | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/src/C/CPS.hs b/src/C/CPS.hs index d796a36..b5f3a70 100644 --- a/src/C/CPS.hs +++ b/src/C/CPS.hs @@ -21,6 +21,7 @@ module C.CPS , Freevars(..) ) where +import Control.Exception import Control.Monad.Cont import Control.Monad.Reader import Data.Foldable @@ -31,6 +32,14 @@ import Syntax hiding (Exp(..)) import qualified Data.Set as Set import qualified Syntax as S +newtype CException = ExpNotImplementedException S.Exp + +instance Show CException where + show = \case + (ExpNotImplementedException e) -> "ExpNotImplementedException: Expression " ++ show e ++ " is not yet compilable to C" + +instance Exception CException + data Val = Lit Literal | Var Ident @@ -121,7 +130,7 @@ fromExp :: S.Exp -> (Val -> Reader Vars Exp) -> Reader Vars Exp fromExp e = runContT (fromExpC e) fromExpC :: S.Exp -> ContT Exp (Reader Vars) Val -fromExpC = \case +fromExpC expr = case expr of S.Lit l -> pure (Lit l) S.Var v -> do vBound <- isBound v @@ -167,6 +176,8 @@ fromExpC = \case S.Recv e -> do v <- fromExpC e captured $ pure . Recv v . Just + + _ -> throw $ ExpNotImplementedException expr getPair :: (forall a. (a, a) -> a) -> S.Exp -> ContT Exp (Reader Vars) Val getPair f e = do @@ -178,7 +189,7 @@ getPair f e = do LetPair xfst xsnd v <$> bound2 xfst xsnd (k x) fromExp' :: S.Exp -> Reader Vars Exp -fromExp' = \case +fromExp' expr = case expr of S.Var v -> do vBound <- isBound v if vBound @@ -208,6 +219,8 @@ fromExp' = \case e@S.Fork{} -> trivial e e@S.New{} -> trivial e e@S.Send{} -> trivial e + + _ -> throw $ ExpNotImplementedException expr where trivial e = fromExp e (pure . Return) From dae63c47f886a20c6352e491a58ecbadc578308c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 2 Mar 2023 14:01:41 +0100 Subject: [PATCH 180/229] Changed terminology of introduce --- src/Networking/Incoming.hs | 9 +-------- src/Networking/Messages.hs | 4 ++-- src/Networking/Outgoing.hs | 4 ++-- src/Networking/Serialize.hs | 15 ++------------- src/ValueParsing/ValueGrammar.y | 4 ++-- src/ValueParsing/ValueTokens.x | 6 +++--- 6 files changed, 12 insertions(+), 30 deletions(-) diff --git a/src/Networking/Incoming.hs b/src/Networking/Incoming.hs index 643b9d3..5802d06 100644 --- a/src/Networking/Incoming.hs +++ b/src/Networking/Incoming.hs @@ -83,14 +83,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria NC.sendResponse hdl Messages.Okay NCon.disconnectFromPartner ncToPartner SSem.signal $ ncHandlingIncomingMessage ncToPartner - -- Config.traceNetIO "Trying to send AcknowledgeDisconnect" - -- NO.sendNetworkMessage activeCons ncToPartner (Messages.AcknowledgeDisconnect $ ncOwnUserID ncToPartner) 0 - -- Config.traceNetIO "Sent AcknowledgeDisconnect" return () - {-AcknowledgeDisconnect userid -> do - NCon.disconnectFromPartner ncToPartner - SSem.signal $ ncHandlingIncomingMessage ncToPartner - NC.sendResponse hdl Messages.Okay-} _ -> do serial <- NSerialize.serialize deserialmessages recievedNetLog message $ "Error unsupported networkmessage: "++ serial @@ -109,7 +102,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria Nothing -> do recievedNetLog message "Recieved message from unknown connection" case deserialmessages of - IntroduceClient userid clientport synname syntype -> do + Introduce userid clientport synname syntype -> do serverid <- RandomID.newRandomID newpeer <- newNetworkConnection userid serverid clientHostaddress clientport userid serverid NC.sendResponse hdl (Messages.OkayIntroduce serverid) diff --git a/src/Networking/Messages.hs b/src/Networking/Messages.hs index 1573646..2c9bdaf 100644 --- a/src/Networking/Messages.hs +++ b/src/Networking/Messages.hs @@ -12,7 +12,7 @@ type ConversationID = String type ConnectionID = String data Message - = IntroduceClient UserID Port Type Type + = Introduce UserID Port Type Type | NewValue UserID Int Value | RequestValue UserID Int | AcknowledgeValue UserID Int @@ -37,7 +37,7 @@ data ConversationSession getUserID :: Message -> String getUserID = \case - IntroduceClient p _ _ _ -> p + Introduce p _ _ _ -> p NewValue p _ _ -> p RequestValue p _ -> p AcknowledgeValue p _ -> p diff --git a/src/Networking/Outgoing.hs b/src/Networking/Outgoing.hs index 073ff2a..9ad071c 100644 --- a/src/Networking/Outgoing.hs +++ b/src/Networking/Outgoing.hs @@ -151,13 +151,13 @@ initialConnect activeCons mvar hostname port ownport syntype= do case mbycon of Just con -> do ownuserid <- RandomID.newRandomID - NC.sendMessage con (Messages.IntroduceClient ownuserid ownport (fst syntype) $ snd syntype) + NC.sendMessage con (Messages.Introduce ownuserid ownport (fst syntype) $ snd syntype) mbyintroductionanswer <- NC.recieveResponse con 10000 (-1) NC.endConversation con 10000 10 case mbyintroductionanswer of Just introduction -> case introduction of OkayIntroduce introductionanswer -> do - msgserial <- NSerialize.serialize $ Messages.IntroduceClient ownuserid ownport (fst syntype) $ snd syntype + msgserial <- NSerialize.serialize $ Messages.Introduce ownuserid ownport (fst syntype) $ snd syntype Config.traceNetIO $ "Sending message as: " ++ ownuserid ++ " to: " ++ introductionanswer Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port Config.traceNetIO $ " Message: " ++ msgserial diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index cc2e53c..a27d006 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -38,11 +38,11 @@ instance Serializable Response where Okay -> return "NOkay" OkayIntroduce u -> serializeLabeledEntry "NOkayIntroduce" u Wait -> return "NWait" - Error -> return "Error" + Error -> return "NError" instance Serializable Message where serialize = \case - IntroduceClient p port tn t -> serializeLabeledEntryMulti "NIntroduceClient" p $ sNext port $ sNext tn $ sLast t + Introduce p port tn t -> serializeLabeledEntryMulti "NIntroduce" p $ sNext port $ sNext tn $ sLast t NewValue p c v -> serializeLabeledEntryMulti "NNewValue" p $ sNext c $ sLast v RequestValue p c -> serializeLabeledEntryMulti "NRequestValue" p $ sLast c AcknowledgeValue p c -> serializeLabeledEntryMulti "NAcknowledgeValue" p $ sLast c @@ -51,16 +51,6 @@ instance Serializable Message where Disconnect p -> serializeLabeledEntry "NDisconnect" p AcknowledgeDisconnect p -> serializeLabeledEntry "NAcknowledgeDisconnect" p -{- -instance Serializable (NCon.NetworkConnection Value) where - serialize con = do - constate <- MVar.readMVar $ NCon.ncConnectionState con - -- (readList, readUnread, readUnAck) <- NB.serializeMinimal $ NCon.ncRead con - -- (writeList, writeUnread, writeUnAck) <- NB.serializeMinimal $ NCon.ncWrite con - - serializeLabeledEntryMulti "SNetworkConnection" (NCon.ncRead con) $ sNext (NCon.ncWrite con) $ sNext (NCon.ncPartnerUserID con) $ sNext (NCon.ncOwnUserID con) $ sLast constate --} - instance Serializable NCon.ConnectionState where serialize = \case NCon.Connected hostname port partnerConnectionID _ _ -> serializeLabeledEntryMulti "SConnected" hostname $ sNext port $ sLast partnerConnectionID @@ -81,7 +71,6 @@ instance Serializable Value where VFuncCast v ft1 ft2 -> serializeLabeledEntryMulti "VFuncCast" v $ sNext ft1 $ sLast ft2 VRec env f x e0 e1 -> serializeLabeledEntryMulti "VRec" env $ sNext f $ sNext x $ sNext e0 $ sLast e1 VNewNatRec env f n tid ty ez x es -> serializeLabeledEntryMulti "VNewNatRec" env $ sNext f $ sNext n $ sNext tid $ sNext ty $ sNext ez $ sNext x $ sLast es - -- VChan nc _-> serializeLabeledEntry "VChan" nc VChan {} -> throw $ UnserializableException "VChan" VChanSerial r w p o c -> serializeLabeledEntryMulti "VChanSerial" r $ sNext w $ sNext p $ sNext o $ sLast c diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index f6190dc..021eaa2 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -115,7 +115,7 @@ import qualified ValueParsing.ValueTokens as T sdirectionalconnection {T _ T.SDirectionalConnection} sconnected {T _ T.SConnected} - nintroduceclient { T _ T.NIntroduceClient } + nintroduce { T _ T.NIntroduce } nnewvalue { T _ T.NNewValue } nrequestvalue { T _ T.NRequestValue } nacknowledgevalue {T _ T.NAcknowledgeValue } @@ -282,7 +282,7 @@ GType : gunit {GUnit} | gdouble {GDouble} | gstring {GString} -Message : nintroduceclient '(' String ')' '(' String ')' '(' Type ')' '(' Type ')' {IntroduceClient $3 $6 $9 $12} +Message : nintroduce '(' String ')' '(' String ')' '(' Type ')' '(' Type ')' {Introduce $3 $6 $9 $12} | nnewvalue '(' String ')' '(' int ')' '(' Value ')' {NewValue $3 $6 $9} | nrequestvalue '(' String ')' '(' int ')' {RequestValue $3 $6} | nacknowledgevalue '(' String ')' '(' int ')' {AcknowledgeValue $3 $6} diff --git a/src/ValueParsing/ValueTokens.x b/src/ValueParsing/ValueTokens.x index b93cc61..43d27c0 100644 --- a/src/ValueParsing/ValueTokens.x +++ b/src/ValueParsing/ValueTokens.x @@ -120,12 +120,12 @@ tokens :- "SStringExpArray" { tok $ const SStringExpArray } "SStringTypeArray" { tok $ const SStringTypeArray } "SStringArray" { tok $ const SStringArray } - "SValuesArray" { tok $ const SValuesArray } + "SValuesArray" { tok $ const SValuesArray } "SNetworkConnection" { tok $ const SNetworkConnection} "SDirectionalConnection" { tok $ const SDirectionalConnection} "SConnected" { tok $ const SConnected} - "NIntroduceClient" { tok $ const NIntroduceClient } + "NIntroduce" { tok $ const NIntroduce } "NNewValue" { tok $ const NNewValue } "NRequestValue" { tok $ const NRequestValue } "NAcknowledgeValue" { tok $ const NAcknowledgeValue } @@ -254,7 +254,7 @@ data Token | SDirectionalConnection | SConnected - | NIntroduceClient + | NIntroduce | NNewValue | NRequestValue | NAcknowledgeValue From 47949a154a8c198f0ebd8ae3ed72540bc9c1d29d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 2 Mar 2023 17:21:08 +0100 Subject: [PATCH 181/229] Added the recursion test Seems to work, but I wont include it into my tests due to the ridiculous run length of it --- dev-examples/recursion/client.ldgv | 45 ++++++++++++++++++++++++++++++ dev-examples/recursion/server.ldgv | 45 ++++++++++++++++++++++++++++++ 2 files changed, 90 insertions(+) create mode 100644 dev-examples/recursion/client.ldgv create mode 100644 dev-examples/recursion/server.ldgv diff --git a/dev-examples/recursion/client.ldgv b/dev-examples/recursion/client.ldgv new file mode 100644 index 0000000..d6b21cc --- /dev/null +++ b/dev-examples/recursion/client.ldgv @@ -0,0 +1,45 @@ +type End : ~unit = Unit + +type SUMC : ~ssn = + ?(n : Nat) + natrec n + { !Int. End + , A. ?Int. A + } + +type SUM : ~ssn = + !(n : Nat) + natrec n + { ?Int. End + , A. !Int. A + } + +-- sum up incoming numbers +val sum (ch_in : SUMC) : End = + let = recv ch_in in + (natrec n + { fn (m : Int) fn (c : !Int.End) + send c m + , n1 . A . (y : (m : Int) -> (a:A) -> End) . + fn (m: Int) fn (c : ?Int. A) + let = recv c in + y (k + m) c + } + ) 0 ch + +-- sends the numbers n to 1 +val sendsum (ch_out : SUM) (n : Nat) : Int = + let ch = send ch_out n in + (natrec n + { fn (c : ?Int.End) + fst (recv c) + , n1 . A . (y : (a:A) -> Int) . + fn (c : !Int. A) + y (send c (n1 + 1)) + }) ch + +-- | the summation should be (n^2 + n) / 2 -> with 1000 it should return 500500 +val main : End +val main = + let a = (connect 4100 SUMC "127.0.0.1" 4000) in + sum a diff --git a/dev-examples/recursion/server.ldgv b/dev-examples/recursion/server.ldgv new file mode 100644 index 0000000..235f0ff --- /dev/null +++ b/dev-examples/recursion/server.ldgv @@ -0,0 +1,45 @@ +type End : ~unit = Unit + +type SUMC : ~ssn = + ?(n : Nat) + natrec n + { !Int. End + , A. ?Int. A + } + +type SUM : ~ssn = + !(n : Nat) + natrec n + { ?Int. End + , A. !Int. A + } + +-- sum up incoming numbers +val sum (ch_in : SUMC) : End = + let = recv ch_in in + (natrec n + { fn (m : Int) fn (c : !Int.End) + send c m + , n1 . A . (y : (m : Int) -> (a:A) -> End) . + fn (m: Int) fn (c : ?Int. A) + let = recv c in + y (k + m) c + } + ) 0 ch + +-- sends the numbers n to 1 +val sendsum (ch_out : SUM) (n : Nat) : Int = + let ch = send ch_out n in + (natrec n + { fn (c : ?Int.End) + fst (recv c) + , n1 . A . (y : (a:A) -> Int) . + fn (c : !Int. A) + y (send c (n1 + 1)) + }) ch + +-- | the summation should be (n^2 + n) / 2 -> with 1000 it should return 500500 +val main : Int +val main = + let b = (accept 4000 (dualof SUMC)) in + sendsum b 1000 From 7d52e52216350d057720e51b6965a4435f84aff4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 2 Mar 2023 18:50:23 +0100 Subject: [PATCH 182/229] Added another test --- dev-examples/handoff7/add.ldgvnw | 23 +++++++++++++++++++++++ dev-examples/handoff7/handoff.ldgvnw | 14 ++++++++++++++ testNWCount.sh | 1 + testNWCountHigh.sh | 1 + testOftenHandoff7.sh | 3 +++ 5 files changed, 42 insertions(+) create mode 100644 dev-examples/handoff7/add.ldgvnw create mode 100644 dev-examples/handoff7/handoff.ldgvnw create mode 100644 testOftenHandoff7.sh diff --git a/dev-examples/handoff7/add.ldgvnw b/dev-examples/handoff7/add.ldgvnw new file mode 100644 index 0000000..640dc75 --- /dev/null +++ b/dev-examples/handoff7/add.ldgvnw @@ -0,0 +1,23 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit +type SendOneInt : ! ~ssn = !Int. Unit +type SendRecvOneInt : ! ~ssn = !(dualof SendOneInt). Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let y = ((send x) 42) in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let con = (connect 4100 SendRecvOneInt "127.0.0.1" 4000) in + let con2 = (send con) c2 in + (m) + +val main : Int +val main = + let = (new SendInt) in + let a1 = fork (send2 a) in + add2 b diff --git a/dev-examples/handoff7/handoff.ldgvnw b/dev-examples/handoff7/handoff.ldgvnw new file mode 100644 index 0000000..be92ae9 --- /dev/null +++ b/dev-examples/handoff7/handoff.ldgvnw @@ -0,0 +1,14 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit +type SendOneInt : ! ~ssn = !Int. Unit +type SendRecvOneInt : ! ~ssn = !(dualof SendOneInt). Unit + + +val main : Int +val main = + let con = (accept 4000 (dualof SendRecvOneInt)) in + let = recv con in + let = recv recvint in + (n) diff --git a/testNWCount.sh b/testNWCount.sh index c4dceee..b119319 100644 --- a/testNWCount.sh +++ b/testNWCount.sh @@ -8,5 +8,6 @@ for i in {1..1000}; do clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/client.ldgvnw & wait); clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff5/handoff.ldgvnw & wait); clear; echo "$i Handoff6"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff6/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff6/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff6/client.ldgvnw & wait); + clear; echo "$i Handoff7"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff7/add.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff7/handoff.ldgvnw & wait); clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/client.ldgvnw & wait); done \ No newline at end of file diff --git a/testNWCountHigh.sh b/testNWCountHigh.sh index 903813e..8aa1102 100644 --- a/testNWCountHigh.sh +++ b/testNWCountHigh.sh @@ -8,5 +8,6 @@ for i in {1..20000}; do clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/client.ldgvnw & wait); clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff5/handoff.ldgvnw & wait); clear; echo "$i Handoff6"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff6/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff6/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff6/client.ldgvnw & wait); + clear; echo "$i Handoff7"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff7/add.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff7/handoff.ldgvnw & wait); clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/client.ldgvnw & wait); done \ No newline at end of file diff --git a/testOftenHandoff7.sh b/testOftenHandoff7.sh new file mode 100644 index 0000000..0a0bec1 --- /dev/null +++ b/testOftenHandoff7.sh @@ -0,0 +1,3 @@ +for i in {1..2000}; do + clear; echo "$i Handoff7"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff7/add.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff7/handoff.ldgvnw & wait); +done \ No newline at end of file From e81665cca8641f7e62149db267afd4615450a8b4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 6 Mar 2023 12:12:00 +0100 Subject: [PATCH 183/229] Gave the recursion test the correct file extention --- dev-examples/recursion/{client.ldgv => client.ldgvnw} | 0 dev-examples/recursion/{server.ldgv => server.ldgvnw} | 0 src/Networking/Incoming.hs | 2 +- testNWCount.sh | 2 +- testOftenRecursion.sh | 3 +++ testRecursion.sh | 2 ++ 6 files changed, 7 insertions(+), 2 deletions(-) rename dev-examples/recursion/{client.ldgv => client.ldgvnw} (100%) rename dev-examples/recursion/{server.ldgv => server.ldgvnw} (100%) create mode 100644 testOftenRecursion.sh create mode 100644 testRecursion.sh diff --git a/dev-examples/recursion/client.ldgv b/dev-examples/recursion/client.ldgvnw similarity index 100% rename from dev-examples/recursion/client.ldgv rename to dev-examples/recursion/client.ldgvnw diff --git a/dev-examples/recursion/server.ldgv b/dev-examples/recursion/server.ldgvnw similarity index 100% rename from dev-examples/recursion/server.ldgv rename to dev-examples/recursion/server.ldgvnw diff --git a/src/Networking/Incoming.hs b/src/Networking/Incoming.hs index 5802d06..b1c3789 100644 --- a/src/Networking/Incoming.hs +++ b/src/Networking/Incoming.hs @@ -209,7 +209,7 @@ replaceVChanSerial activeCons mvar input = modifyVChans (handleSerial activeCons recieveValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value recieveValue vchanconsvar activeCons networkconnection ownport = do - recieveValueInternal 0 vchanconsvar activeCons networkconnection ownport + recieveValueInternal 100 vchanconsvar activeCons networkconnection ownport where recieveValueInternal :: Int -> VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value recieveValueInternal count vchanconsvar activeCons networkconnection ownport = do diff --git a/testNWCount.sh b/testNWCount.sh index b119319..b097735 100644 --- a/testNWCount.sh +++ b/testNWCount.sh @@ -1,4 +1,4 @@ -for i in {1..1000}; do +for i in {1..10}; do clear; echo "$i Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/add/server.ldgvnw & stack run ldgv -- interpret < dev-examples/add/client.ldgvnw & wait); clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/simple/server.ldgvnw & stack run ldgv -- interpret < dev-examples/simple/client.ldgvnw & wait); clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirectional/client.ldgvnw & wait); diff --git a/testOftenRecursion.sh b/testOftenRecursion.sh new file mode 100644 index 0000000..8fc4f73 --- /dev/null +++ b/testOftenRecursion.sh @@ -0,0 +1,3 @@ +for i in {1..10}; do + bash testRecursion.sh; +done \ No newline at end of file diff --git a/testRecursion.sh b/testRecursion.sh new file mode 100644 index 0000000..1fb866d --- /dev/null +++ b/testRecursion.sh @@ -0,0 +1,2 @@ +clear; echo "Recursion"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/recursion/server.ldgvnw & stack run ldgv -- interpret < dev-examples/recursion/client.ldgvnw & wait); +exit; \ No newline at end of file From 3aae69244529d71ebd642972c2768c9fa4d5f206 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 6 Mar 2023 13:11:29 +0100 Subject: [PATCH 184/229] Moved examples to a better folder --- .../add/client.ldgvnw | 0 .../add/server.ldgvnw | 0 .../bidirectional/client.ldgvnw | 0 .../bidirectional/server.ldgvnw | 0 .../bidirhandoff/client.ldgvnw | 0 .../bidirhandoff/clienthandoff.ldgvnw | 0 .../bidirhandoff/server.ldgvnw | 0 .../bidirhandoff/serverhandoff.ldgvnw | 0 .../handoff/client.ldgvnw | 0 .../handoff/handoff.ldgvnw | 0 .../handoff/server.ldgvnw | 0 .../handoff2/client.ldgvnw | 0 .../handoff2/handoff.ldgvnw | 0 .../handoff2/server.ldgvnw | 0 .../handoff3/client.ldgvnw | 0 .../handoff3/handoff.ldgvnw | 0 .../handoff3/server.ldgvnw | 0 .../handoff4/client.ldgvnw | 0 .../handoff4/handoff.ldgvnw | 0 .../handoff4/server.ldgvnw | 0 .../handoff5/add.ldgvnw | 0 .../handoff5/handoff.ldgvnw | 0 .../handoff6/client.ldgvnw | 0 .../handoff6/handoff.ldgvnw | 0 .../handoff6/server.ldgvnw | 0 .../handoff7/add.ldgvnw | 0 .../handoff7/handoff.ldgvnw | 0 .../recursion/client.ldgvnw | 0 .../recursion/server.ldgvnw | 0 .../simple/client.ldgvnw | 0 .../simple/server.ldgvnw | 0 src/Networking/Incoming.hs | 2 +- testAdd.sh | 2 +- testBidirectional.sh | 2 +- testBidirhandoff.sh | 2 +- testHandoff.sh | 2 +- testHandoff2.sh | 2 +- testNWCount.sh | 22 +++++++++---------- testNWCountHigh.sh | 22 +++++++++---------- testNWOld.sh | 12 +++++----- testOftenBidirhandoff.sh | 4 ++-- testOftenHandoff3.sh | 2 +- testOftenHandoff4.sh | 2 +- testOftenHandoff5.sh | 2 +- testOftenHandoff6.sh | 2 +- testOftenHandoff7.sh | 2 +- testRecursion.sh | 2 +- testSimple.sh | 2 +- 48 files changed, 43 insertions(+), 43 deletions(-) rename {dev-examples => networking-examples}/add/client.ldgvnw (100%) rename {dev-examples => networking-examples}/add/server.ldgvnw (100%) rename {dev-examples => networking-examples}/bidirectional/client.ldgvnw (100%) rename {dev-examples => networking-examples}/bidirectional/server.ldgvnw (100%) rename {dev-examples => networking-examples}/bidirhandoff/client.ldgvnw (100%) rename {dev-examples => networking-examples}/bidirhandoff/clienthandoff.ldgvnw (100%) rename {dev-examples => networking-examples}/bidirhandoff/server.ldgvnw (100%) rename {dev-examples => networking-examples}/bidirhandoff/serverhandoff.ldgvnw (100%) rename {dev-examples => networking-examples}/handoff/client.ldgvnw (100%) rename {dev-examples => networking-examples}/handoff/handoff.ldgvnw (100%) rename {dev-examples => networking-examples}/handoff/server.ldgvnw (100%) rename {dev-examples => networking-examples}/handoff2/client.ldgvnw (100%) rename {dev-examples => networking-examples}/handoff2/handoff.ldgvnw (100%) rename {dev-examples => networking-examples}/handoff2/server.ldgvnw (100%) rename {dev-examples => networking-examples}/handoff3/client.ldgvnw (100%) rename {dev-examples => networking-examples}/handoff3/handoff.ldgvnw (100%) rename {dev-examples => networking-examples}/handoff3/server.ldgvnw (100%) rename {dev-examples => networking-examples}/handoff4/client.ldgvnw (100%) rename {dev-examples => networking-examples}/handoff4/handoff.ldgvnw (100%) rename {dev-examples => networking-examples}/handoff4/server.ldgvnw (100%) rename {dev-examples => networking-examples}/handoff5/add.ldgvnw (100%) rename {dev-examples => networking-examples}/handoff5/handoff.ldgvnw (100%) rename {dev-examples => networking-examples}/handoff6/client.ldgvnw (100%) rename {dev-examples => networking-examples}/handoff6/handoff.ldgvnw (100%) rename {dev-examples => networking-examples}/handoff6/server.ldgvnw (100%) rename {dev-examples => networking-examples}/handoff7/add.ldgvnw (100%) rename {dev-examples => networking-examples}/handoff7/handoff.ldgvnw (100%) rename {dev-examples => networking-examples}/recursion/client.ldgvnw (100%) rename {dev-examples => networking-examples}/recursion/server.ldgvnw (100%) rename {dev-examples => networking-examples}/simple/client.ldgvnw (100%) rename {dev-examples => networking-examples}/simple/server.ldgvnw (100%) diff --git a/dev-examples/add/client.ldgvnw b/networking-examples/add/client.ldgvnw similarity index 100% rename from dev-examples/add/client.ldgvnw rename to networking-examples/add/client.ldgvnw diff --git a/dev-examples/add/server.ldgvnw b/networking-examples/add/server.ldgvnw similarity index 100% rename from dev-examples/add/server.ldgvnw rename to networking-examples/add/server.ldgvnw diff --git a/dev-examples/bidirectional/client.ldgvnw b/networking-examples/bidirectional/client.ldgvnw similarity index 100% rename from dev-examples/bidirectional/client.ldgvnw rename to networking-examples/bidirectional/client.ldgvnw diff --git a/dev-examples/bidirectional/server.ldgvnw b/networking-examples/bidirectional/server.ldgvnw similarity index 100% rename from dev-examples/bidirectional/server.ldgvnw rename to networking-examples/bidirectional/server.ldgvnw diff --git a/dev-examples/bidirhandoff/client.ldgvnw b/networking-examples/bidirhandoff/client.ldgvnw similarity index 100% rename from dev-examples/bidirhandoff/client.ldgvnw rename to networking-examples/bidirhandoff/client.ldgvnw diff --git a/dev-examples/bidirhandoff/clienthandoff.ldgvnw b/networking-examples/bidirhandoff/clienthandoff.ldgvnw similarity index 100% rename from dev-examples/bidirhandoff/clienthandoff.ldgvnw rename to networking-examples/bidirhandoff/clienthandoff.ldgvnw diff --git a/dev-examples/bidirhandoff/server.ldgvnw b/networking-examples/bidirhandoff/server.ldgvnw similarity index 100% rename from dev-examples/bidirhandoff/server.ldgvnw rename to networking-examples/bidirhandoff/server.ldgvnw diff --git a/dev-examples/bidirhandoff/serverhandoff.ldgvnw b/networking-examples/bidirhandoff/serverhandoff.ldgvnw similarity index 100% rename from dev-examples/bidirhandoff/serverhandoff.ldgvnw rename to networking-examples/bidirhandoff/serverhandoff.ldgvnw diff --git a/dev-examples/handoff/client.ldgvnw b/networking-examples/handoff/client.ldgvnw similarity index 100% rename from dev-examples/handoff/client.ldgvnw rename to networking-examples/handoff/client.ldgvnw diff --git a/dev-examples/handoff/handoff.ldgvnw b/networking-examples/handoff/handoff.ldgvnw similarity index 100% rename from dev-examples/handoff/handoff.ldgvnw rename to networking-examples/handoff/handoff.ldgvnw diff --git a/dev-examples/handoff/server.ldgvnw b/networking-examples/handoff/server.ldgvnw similarity index 100% rename from dev-examples/handoff/server.ldgvnw rename to networking-examples/handoff/server.ldgvnw diff --git a/dev-examples/handoff2/client.ldgvnw b/networking-examples/handoff2/client.ldgvnw similarity index 100% rename from dev-examples/handoff2/client.ldgvnw rename to networking-examples/handoff2/client.ldgvnw diff --git a/dev-examples/handoff2/handoff.ldgvnw b/networking-examples/handoff2/handoff.ldgvnw similarity index 100% rename from dev-examples/handoff2/handoff.ldgvnw rename to networking-examples/handoff2/handoff.ldgvnw diff --git a/dev-examples/handoff2/server.ldgvnw b/networking-examples/handoff2/server.ldgvnw similarity index 100% rename from dev-examples/handoff2/server.ldgvnw rename to networking-examples/handoff2/server.ldgvnw diff --git a/dev-examples/handoff3/client.ldgvnw b/networking-examples/handoff3/client.ldgvnw similarity index 100% rename from dev-examples/handoff3/client.ldgvnw rename to networking-examples/handoff3/client.ldgvnw diff --git a/dev-examples/handoff3/handoff.ldgvnw b/networking-examples/handoff3/handoff.ldgvnw similarity index 100% rename from dev-examples/handoff3/handoff.ldgvnw rename to networking-examples/handoff3/handoff.ldgvnw diff --git a/dev-examples/handoff3/server.ldgvnw b/networking-examples/handoff3/server.ldgvnw similarity index 100% rename from dev-examples/handoff3/server.ldgvnw rename to networking-examples/handoff3/server.ldgvnw diff --git a/dev-examples/handoff4/client.ldgvnw b/networking-examples/handoff4/client.ldgvnw similarity index 100% rename from dev-examples/handoff4/client.ldgvnw rename to networking-examples/handoff4/client.ldgvnw diff --git a/dev-examples/handoff4/handoff.ldgvnw b/networking-examples/handoff4/handoff.ldgvnw similarity index 100% rename from dev-examples/handoff4/handoff.ldgvnw rename to networking-examples/handoff4/handoff.ldgvnw diff --git a/dev-examples/handoff4/server.ldgvnw b/networking-examples/handoff4/server.ldgvnw similarity index 100% rename from dev-examples/handoff4/server.ldgvnw rename to networking-examples/handoff4/server.ldgvnw diff --git a/dev-examples/handoff5/add.ldgvnw b/networking-examples/handoff5/add.ldgvnw similarity index 100% rename from dev-examples/handoff5/add.ldgvnw rename to networking-examples/handoff5/add.ldgvnw diff --git a/dev-examples/handoff5/handoff.ldgvnw b/networking-examples/handoff5/handoff.ldgvnw similarity index 100% rename from dev-examples/handoff5/handoff.ldgvnw rename to networking-examples/handoff5/handoff.ldgvnw diff --git a/dev-examples/handoff6/client.ldgvnw b/networking-examples/handoff6/client.ldgvnw similarity index 100% rename from dev-examples/handoff6/client.ldgvnw rename to networking-examples/handoff6/client.ldgvnw diff --git a/dev-examples/handoff6/handoff.ldgvnw b/networking-examples/handoff6/handoff.ldgvnw similarity index 100% rename from dev-examples/handoff6/handoff.ldgvnw rename to networking-examples/handoff6/handoff.ldgvnw diff --git a/dev-examples/handoff6/server.ldgvnw b/networking-examples/handoff6/server.ldgvnw similarity index 100% rename from dev-examples/handoff6/server.ldgvnw rename to networking-examples/handoff6/server.ldgvnw diff --git a/dev-examples/handoff7/add.ldgvnw b/networking-examples/handoff7/add.ldgvnw similarity index 100% rename from dev-examples/handoff7/add.ldgvnw rename to networking-examples/handoff7/add.ldgvnw diff --git a/dev-examples/handoff7/handoff.ldgvnw b/networking-examples/handoff7/handoff.ldgvnw similarity index 100% rename from dev-examples/handoff7/handoff.ldgvnw rename to networking-examples/handoff7/handoff.ldgvnw diff --git a/dev-examples/recursion/client.ldgvnw b/networking-examples/recursion/client.ldgvnw similarity index 100% rename from dev-examples/recursion/client.ldgvnw rename to networking-examples/recursion/client.ldgvnw diff --git a/dev-examples/recursion/server.ldgvnw b/networking-examples/recursion/server.ldgvnw similarity index 100% rename from dev-examples/recursion/server.ldgvnw rename to networking-examples/recursion/server.ldgvnw diff --git a/dev-examples/simple/client.ldgvnw b/networking-examples/simple/client.ldgvnw similarity index 100% rename from dev-examples/simple/client.ldgvnw rename to networking-examples/simple/client.ldgvnw diff --git a/dev-examples/simple/server.ldgvnw b/networking-examples/simple/server.ldgvnw similarity index 100% rename from dev-examples/simple/server.ldgvnw rename to networking-examples/simple/server.ldgvnw diff --git a/src/Networking/Incoming.hs b/src/Networking/Incoming.hs index b1c3789..5802d06 100644 --- a/src/Networking/Incoming.hs +++ b/src/Networking/Incoming.hs @@ -209,7 +209,7 @@ replaceVChanSerial activeCons mvar input = modifyVChans (handleSerial activeCons recieveValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value recieveValue vchanconsvar activeCons networkconnection ownport = do - recieveValueInternal 100 vchanconsvar activeCons networkconnection ownport + recieveValueInternal 0 vchanconsvar activeCons networkconnection ownport where recieveValueInternal :: Int -> VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value recieveValueInternal count vchanconsvar activeCons networkconnection ownport = do diff --git a/testAdd.sh b/testAdd.sh index a57d1a4..2c22921 100644 --- a/testAdd.sh +++ b/testAdd.sh @@ -1,2 +1,2 @@ -clear; echo "Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/add/server.ldgvnw & stack run ldgv -- interpret < dev-examples/add/client.ldgvnw & wait); +clear; echo "Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/add/server.ldgvnw & stack run ldgv -- interpret < networking-examples/add/client.ldgvnw & wait); exit; \ No newline at end of file diff --git a/testBidirectional.sh b/testBidirectional.sh index f8fed7d..64307fe 100644 --- a/testBidirectional.sh +++ b/testBidirectional.sh @@ -1,2 +1,2 @@ -clear; echo "Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirectional/client.ldgvnw & wait); +clear; echo "Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirectional/client.ldgvnw & wait); exit; \ No newline at end of file diff --git a/testBidirhandoff.sh b/testBidirhandoff.sh index e1c18b8..d642f64 100644 --- a/testBidirhandoff.sh +++ b/testBidirhandoff.sh @@ -1,2 +1,2 @@ -clear; echo "Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/client.ldgvnw & wait); +clear; echo "Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/client.ldgvnw & wait); exit; \ No newline at end of file diff --git a/testHandoff.sh b/testHandoff.sh index 1e622ab..a92a3a0 100644 --- a/testHandoff.sh +++ b/testHandoff.sh @@ -1,2 +1,2 @@ -clear; echo "Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff/client.ldgvnw & wait); +clear; echo "Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff/client.ldgvnw & wait); exit; \ No newline at end of file diff --git a/testHandoff2.sh b/testHandoff2.sh index ae9c227..86a3a06 100644 --- a/testHandoff2.sh +++ b/testHandoff2.sh @@ -1,2 +1,2 @@ -clear; echo "Handoff2"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/client.ldgvnw & wait); +clear; echo "Handoff2"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff2/client.ldgvnw & wait); exit; \ No newline at end of file diff --git a/testNWCount.sh b/testNWCount.sh index b097735..86b3e32 100644 --- a/testNWCount.sh +++ b/testNWCount.sh @@ -1,13 +1,13 @@ for i in {1..10}; do - clear; echo "$i Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/add/server.ldgvnw & stack run ldgv -- interpret < dev-examples/add/client.ldgvnw & wait); - clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/simple/server.ldgvnw & stack run ldgv -- interpret < dev-examples/simple/client.ldgvnw & wait); - clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirectional/client.ldgvnw & wait); - clear; echo "$i Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff/client.ldgvnw & wait); - clear; echo "$i Handoff2"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/client.ldgvnw & wait); - clear; echo "$i Handoff3"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff3/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/client.ldgvnw & wait); - clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/client.ldgvnw & wait); - clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff5/handoff.ldgvnw & wait); - clear; echo "$i Handoff6"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff6/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff6/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff6/client.ldgvnw & wait); - clear; echo "$i Handoff7"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff7/add.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff7/handoff.ldgvnw & wait); - clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/client.ldgvnw & wait); + clear; echo "$i Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/add/server.ldgvnw & stack run ldgv -- interpret < networking-examples/add/client.ldgvnw & wait); + clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/simple/server.ldgvnw & stack run ldgv -- interpret < networking-examples/simple/client.ldgvnw & wait); + clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirectional/client.ldgvnw & wait); + clear; echo "$i Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff/client.ldgvnw & wait); + clear; echo "$i Handoff2"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff2/client.ldgvnw & wait); + clear; echo "$i Handoff3"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff3/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff3/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff3/client.ldgvnw & wait); + clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff4/client.ldgvnw & wait); + clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff5/handoff.ldgvnw & wait); + clear; echo "$i Handoff6"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff6/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff6/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff6/client.ldgvnw & wait); + clear; echo "$i Handoff7"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff7/add.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff7/handoff.ldgvnw & wait); + clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/client.ldgvnw & wait); done \ No newline at end of file diff --git a/testNWCountHigh.sh b/testNWCountHigh.sh index 8aa1102..9b84f30 100644 --- a/testNWCountHigh.sh +++ b/testNWCountHigh.sh @@ -1,13 +1,13 @@ for i in {1..20000}; do - clear; echo "$i Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/add/server.ldgvnw & stack run ldgv -- interpret < dev-examples/add/client.ldgvnw & wait); - clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/simple/server.ldgvnw & stack run ldgv -- interpret < dev-examples/simple/client.ldgvnw & wait); - clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirectional/client.ldgvnw & wait); - clear; echo "$i Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff/client.ldgvnw & wait); - clear; echo "$i Handoff2"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/client.ldgvnw & wait); - clear; echo "$i Handoff3"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff3/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/client.ldgvnw & wait); - clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/client.ldgvnw & wait); - clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff5/handoff.ldgvnw & wait); - clear; echo "$i Handoff6"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff6/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff6/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff6/client.ldgvnw & wait); - clear; echo "$i Handoff7"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff7/add.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff7/handoff.ldgvnw & wait); - clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/client.ldgvnw & wait); + clear; echo "$i Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/add/server.ldgvnw & stack run ldgv -- interpret < networking-examples/add/client.ldgvnw & wait); + clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/simple/server.ldgvnw & stack run ldgv -- interpret < networking-examples/simple/client.ldgvnw & wait); + clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirectional/client.ldgvnw & wait); + clear; echo "$i Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff/client.ldgvnw & wait); + clear; echo "$i Handoff2"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff2/client.ldgvnw & wait); + clear; echo "$i Handoff3"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff3/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff3/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff3/client.ldgvnw & wait); + clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff4/client.ldgvnw & wait); + clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff5/handoff.ldgvnw & wait); + clear; echo "$i Handoff6"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff6/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff6/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff6/client.ldgvnw & wait); + clear; echo "$i Handoff7"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff7/add.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff7/handoff.ldgvnw & wait); + clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/client.ldgvnw & wait); done \ No newline at end of file diff --git a/testNWOld.sh b/testNWOld.sh index 05396c2..2e386aa 100644 --- a/testNWOld.sh +++ b/testNWOld.sh @@ -1,14 +1,14 @@ for i in {1..100}; do - clear; echo "Add"; stack run ldgv -- interpret < dev-examples/add/server.ldgvnw & stack run ldgv -- interpret < dev-examples/add/client.ldgvnw; + clear; echo "Add"; stack run ldgv -- interpret < networking-examples/add/server.ldgvnw & stack run ldgv -- interpret < networking-examples/add/client.ldgvnw; sleep 0.5; - clear; echo "Simple"; stack run ldgv -- interpret < dev-examples/simple/server.ldgvnw & stack run ldgv -- interpret < dev-examples/simple/client.ldgvnw; + clear; echo "Simple"; stack run ldgv -- interpret < networking-examples/simple/server.ldgvnw & stack run ldgv -- interpret < networking-examples/simple/client.ldgvnw; sleep 0.5; - clear; echo "Bidirectional"; stack run ldgv -- interpret < dev-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirectional/client.ldgvnw; + clear; echo "Bidirectional"; stack run ldgv -- interpret < networking-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirectional/client.ldgvnw; sleep 0.5; - clear; echo "Handoff"; stack run ldgv -- interpret < dev-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff/client.ldgvnw; + clear; echo "Handoff"; stack run ldgv -- interpret < networking-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff/client.ldgvnw; sleep 0.5; - # clear; echo "Handoff2"; stack run ldgv -- interpret < dev-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff2/client.ldgvnw; + # clear; echo "Handoff2"; stack run ldgv -- interpret < networking-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff2/client.ldgvnw; # sleep 0.5; - # clear; echo "Bidirhandoff"; stack run ldgv -- interpret < dev-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/client.ldgvnw; + # clear; echo "Bidirhandoff"; stack run ldgv -- interpret < networking-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/client.ldgvnw; # sleep 0.5; done \ No newline at end of file diff --git a/testOftenBidirhandoff.sh b/testOftenBidirhandoff.sh index 2c0dcbf..04c8c0a 100644 --- a/testOftenBidirhandoff.sh +++ b/testOftenBidirhandoff.sh @@ -1,3 +1,3 @@ -for i in {1..2000}; do - clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < dev-examples/bidirhandoff/client.ldgvnw & wait); +for i in {1..100}; do + clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/client.ldgvnw & wait); done \ No newline at end of file diff --git a/testOftenHandoff3.sh b/testOftenHandoff3.sh index 5c3ba4e..7133e08 100644 --- a/testOftenHandoff3.sh +++ b/testOftenHandoff3.sh @@ -1,3 +1,3 @@ for i in {1..200000}; do - clear; echo "$i Handoff3"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff3/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff3/client.ldgvnw & wait); + clear; echo "$i Handoff3"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff3/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff3/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff3/client.ldgvnw & wait); done \ No newline at end of file diff --git a/testOftenHandoff4.sh b/testOftenHandoff4.sh index e48887d..2a20e37 100644 --- a/testOftenHandoff4.sh +++ b/testOftenHandoff4.sh @@ -1,3 +1,3 @@ for i in {1..2000}; do - clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff4/client.ldgvnw & wait); + clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff4/client.ldgvnw & wait); done \ No newline at end of file diff --git a/testOftenHandoff5.sh b/testOftenHandoff5.sh index 5f89635..12aebcc 100644 --- a/testOftenHandoff5.sh +++ b/testOftenHandoff5.sh @@ -1,3 +1,3 @@ for i in {1..2000}; do - clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff5/handoff.ldgvnw & wait); + clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff5/handoff.ldgvnw & wait); done \ No newline at end of file diff --git a/testOftenHandoff6.sh b/testOftenHandoff6.sh index 0b70262..489f2bf 100644 --- a/testOftenHandoff6.sh +++ b/testOftenHandoff6.sh @@ -1,3 +1,3 @@ for i in {1..2000}; do - clear; echo "$i Handoff6"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff6/server.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff6/handoff.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff6/client.ldgvnw & wait); + clear; echo "$i Handoff6"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff6/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff6/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff6/client.ldgvnw & wait); done \ No newline at end of file diff --git a/testOftenHandoff7.sh b/testOftenHandoff7.sh index 0a0bec1..f6db69a 100644 --- a/testOftenHandoff7.sh +++ b/testOftenHandoff7.sh @@ -1,3 +1,3 @@ for i in {1..2000}; do - clear; echo "$i Handoff7"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/handoff7/add.ldgvnw & stack run ldgv -- interpret < dev-examples/handoff7/handoff.ldgvnw & wait); + clear; echo "$i Handoff7"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff7/add.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff7/handoff.ldgvnw & wait); done \ No newline at end of file diff --git a/testRecursion.sh b/testRecursion.sh index 1fb866d..d9a1b84 100644 --- a/testRecursion.sh +++ b/testRecursion.sh @@ -1,2 +1,2 @@ -clear; echo "Recursion"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/recursion/server.ldgvnw & stack run ldgv -- interpret < dev-examples/recursion/client.ldgvnw & wait); +clear; echo "Recursion"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/recursion/server.ldgvnw & stack run ldgv -- interpret < networking-examples/recursion/client.ldgvnw & wait); exit; \ No newline at end of file diff --git a/testSimple.sh b/testSimple.sh index 9f40056..6e1e681 100644 --- a/testSimple.sh +++ b/testSimple.sh @@ -1,2 +1,2 @@ -clear; echo "Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < dev-examples/simple/server.ldgvnw & stack run ldgv -- interpret < dev-examples/simple/client.ldgvnw & wait); +clear; echo "Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/simple/server.ldgvnw & stack run ldgv -- interpret < networking-examples/simple/client.ldgvnw & wait); exit; \ No newline at end of file From 9ade0ee99a0057cd21448cec3e62fdafee710bc8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 6 Mar 2023 13:20:59 +0100 Subject: [PATCH 185/229] Moved tests into appropriate folder --- networking-tests/testAdd.sh | 2 ++ networking-tests/testBidirectional.sh | 2 ++ networking-tests/testBidirhandoff.sh | 2 ++ networking-tests/testHandoff.sh | 2 ++ networking-tests/testHandoff2.sh | 2 ++ networking-tests/testLDGVTests.sh | 21 +++++++++++++++++++ testNW.sh => networking-tests/testNW.sh | 0 networking-tests/testNWCount.sh | 13 ++++++++++++ networking-tests/testNWCountHigh.sh | 13 ++++++++++++ networking-tests/testNWOld.sh | 14 +++++++++++++ networking-tests/testOftenBidirhandoff.sh | 3 +++ .../testOftenHandoff.sh | 0 .../testOftenHandoff2.sh | 0 networking-tests/testOftenHandoff3.sh | 3 +++ networking-tests/testOftenHandoff4.sh | 3 +++ networking-tests/testOftenHandoff5.sh | 3 +++ networking-tests/testOftenHandoff6.sh | 3 +++ networking-tests/testOftenHandoff7.sh | 3 +++ .../testOftenRecursion.sh | 0 networking-tests/testRecursion.sh | 2 ++ networking-tests/testSimple.sh | 2 ++ testAdd.sh | 2 -- testBidirectional.sh | 2 -- testBidirhandoff.sh | 2 -- testHandoff.sh | 2 -- testHandoff2.sh | 2 -- testLDGVTests.sh | 21 ------------------- testNWCount.sh | 13 ------------ testNWCountHigh.sh | 13 ------------ testNWOld.sh | 14 ------------- testOftenBidirhandoff.sh | 3 --- testOftenHandoff3.sh | 3 --- testOftenHandoff4.sh | 3 --- testOftenHandoff5.sh | 3 --- testOftenHandoff6.sh | 3 --- testOftenHandoff7.sh | 3 --- testRecursion.sh | 2 -- testSimple.sh | 2 -- 38 files changed, 93 insertions(+), 93 deletions(-) create mode 100644 networking-tests/testAdd.sh create mode 100644 networking-tests/testBidirectional.sh create mode 100644 networking-tests/testBidirhandoff.sh create mode 100644 networking-tests/testHandoff.sh create mode 100644 networking-tests/testHandoff2.sh create mode 100644 networking-tests/testLDGVTests.sh rename testNW.sh => networking-tests/testNW.sh (100%) create mode 100644 networking-tests/testNWCount.sh create mode 100644 networking-tests/testNWCountHigh.sh create mode 100644 networking-tests/testNWOld.sh create mode 100644 networking-tests/testOftenBidirhandoff.sh rename testOftenHandoff.sh => networking-tests/testOftenHandoff.sh (100%) rename testOftenHandoff2.sh => networking-tests/testOftenHandoff2.sh (100%) create mode 100644 networking-tests/testOftenHandoff3.sh create mode 100644 networking-tests/testOftenHandoff4.sh create mode 100644 networking-tests/testOftenHandoff5.sh create mode 100644 networking-tests/testOftenHandoff6.sh create mode 100644 networking-tests/testOftenHandoff7.sh rename testOftenRecursion.sh => networking-tests/testOftenRecursion.sh (100%) create mode 100644 networking-tests/testRecursion.sh create mode 100644 networking-tests/testSimple.sh delete mode 100644 testAdd.sh delete mode 100644 testBidirectional.sh delete mode 100644 testBidirhandoff.sh delete mode 100644 testHandoff.sh delete mode 100644 testHandoff2.sh delete mode 100644 testLDGVTests.sh delete mode 100644 testNWCount.sh delete mode 100644 testNWCountHigh.sh delete mode 100644 testNWOld.sh delete mode 100644 testOftenBidirhandoff.sh delete mode 100644 testOftenHandoff3.sh delete mode 100644 testOftenHandoff4.sh delete mode 100644 testOftenHandoff5.sh delete mode 100644 testOftenHandoff6.sh delete mode 100644 testOftenHandoff7.sh delete mode 100644 testRecursion.sh delete mode 100644 testSimple.sh diff --git a/networking-tests/testAdd.sh b/networking-tests/testAdd.sh new file mode 100644 index 0000000..f692519 --- /dev/null +++ b/networking-tests/testAdd.sh @@ -0,0 +1,2 @@ +clear; echo "Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/add/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/add/client.ldgvnw & wait); +exit; \ No newline at end of file diff --git a/networking-tests/testBidirectional.sh b/networking-tests/testBidirectional.sh new file mode 100644 index 0000000..444e8ce --- /dev/null +++ b/networking-tests/testBidirectional.sh @@ -0,0 +1,2 @@ +clear; echo "Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirectional/client.ldgvnw & wait); +exit; \ No newline at end of file diff --git a/networking-tests/testBidirhandoff.sh b/networking-tests/testBidirhandoff.sh new file mode 100644 index 0000000..07ec1fc --- /dev/null +++ b/networking-tests/testBidirhandoff.sh @@ -0,0 +1,2 @@ +clear; echo "Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/client.ldgvnw & wait); +exit; \ No newline at end of file diff --git a/networking-tests/testHandoff.sh b/networking-tests/testHandoff.sh new file mode 100644 index 0000000..b68f9fc --- /dev/null +++ b/networking-tests/testHandoff.sh @@ -0,0 +1,2 @@ +clear; echo "Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/client.ldgvnw & wait); +exit; \ No newline at end of file diff --git a/networking-tests/testHandoff2.sh b/networking-tests/testHandoff2.sh new file mode 100644 index 0000000..667955e --- /dev/null +++ b/networking-tests/testHandoff2.sh @@ -0,0 +1,2 @@ +clear; echo "Handoff2"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff2/client.ldgvnw & wait); +exit; \ No newline at end of file diff --git a/networking-tests/testLDGVTests.sh b/networking-tests/testLDGVTests.sh new file mode 100644 index 0000000..ee81327 --- /dev/null +++ b/networking-tests/testLDGVTests.sh @@ -0,0 +1,21 @@ +clear; echo "add"; stack run ldgv -- interpret < ../examples/add.ldgv +clear; echo "case-singleton"; stack run ldgv -- interpret < ../examples/case-singleton.ldgv +clear; echo "casesub"; stack run ldgv -- interpret < ../examples/casesub.ldgv +clear; echo "casetest"; stack run ldgv -- interpret < ../examples/casetest.ldgv +clear; echo "casts"; stack run ldgv -- interpret < ../examples/casts.ccldgv +clear; echo "depcast"; stack run ldgv -- interpret < ../examples/depcast.ccldgv +clear; echo "depsum"; stack run ldgv -- interpret < ../examples/depsum.ldgv +clear; echo "just-f2"; stack run ldgv -- interpret < ../examples/just-f2.ccldgv +clear; echo "just-f3"; stack run ldgv -- interpret < ../examples/just-f3.ccldgv +clear; echo "mymap"; stack run ldgv -- interpret < ../examples/mymap.gldgv +clear; echo "natsum"; stack run ldgv -- interpret < ../examples/natsum.ldgv +clear; echo "natsum2-new"; stack run ldgv -- interpret < ../examples/natsum2-new.ldgv +clear; echo "natsum2-rec"; stack run ldgv -- interpret < ../examples/natsum2-rec.ldgv +clear; echo "natsum2"; stack run ldgv -- interpret < ../examples/natsum2.ldgv +clear; echo "node"; stack run ldgv -- interpret < ../examples/node.ldgv +clear; echo "noderec"; stack run ldgv -- interpret < ../examples/noderec.ldgv +clear; echo "person"; stack run ldgv -- interpret < ../examples/person.gldgv +clear; echo "simple_recursion"; stack run ldgv -- interpret < ../examples/simple_recursion.ldgv +clear; echo "simple"; stack run ldgv -- interpret < ../examples/simple.ldgv +# clear; echo "tclient"; stack run ldgv -- interpret < ../examples/tclient.ldgv +# clear; echo "tserver"; stack run ldgv -- interpret < ../examples/tserver.ldgv \ No newline at end of file diff --git a/testNW.sh b/networking-tests/testNW.sh similarity index 100% rename from testNW.sh rename to networking-tests/testNW.sh diff --git a/networking-tests/testNWCount.sh b/networking-tests/testNWCount.sh new file mode 100644 index 0000000..80e1db9 --- /dev/null +++ b/networking-tests/testNWCount.sh @@ -0,0 +1,13 @@ +for i in {1..10}; do + clear; echo "$i Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/add/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/add/client.ldgvnw & wait); + clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/simple/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/simple/client.ldgvnw & wait); + clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirectional/client.ldgvnw & wait); + clear; echo "$i Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/client.ldgvnw & wait); + clear; echo "$i Handoff2"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff2/client.ldgvnw & wait); + clear; echo "$i Handoff3"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff3/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff3/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff3/client.ldgvnw & wait); + clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff4/client.ldgvnw & wait); + clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff5/handoff.ldgvnw & wait); + clear; echo "$i Handoff6"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff6/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff6/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff6/client.ldgvnw & wait); + clear; echo "$i Handoff7"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff7/add.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff7/handoff.ldgvnw & wait); + clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/client.ldgvnw & wait); +done \ No newline at end of file diff --git a/networking-tests/testNWCountHigh.sh b/networking-tests/testNWCountHigh.sh new file mode 100644 index 0000000..bf8427b --- /dev/null +++ b/networking-tests/testNWCountHigh.sh @@ -0,0 +1,13 @@ +for i in {1..20000}; do + clear; echo "$i Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/add/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/add/client.ldgvnw & wait); + clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/simple/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/simple/client.ldgvnw & wait); + clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirectional/client.ldgvnw & wait); + clear; echo "$i Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/client.ldgvnw & wait); + clear; echo "$i Handoff2"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff2/client.ldgvnw & wait); + clear; echo "$i Handoff3"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff3/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff3/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff3/client.ldgvnw & wait); + clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff4/client.ldgvnw & wait); + clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff5/handoff.ldgvnw & wait); + clear; echo "$i Handoff6"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff6/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff6/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff6/client.ldgvnw & wait); + clear; echo "$i Handoff7"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff7/add.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff7/handoff.ldgvnw & wait); + clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/client.ldgvnw & wait); +done \ No newline at end of file diff --git a/networking-tests/testNWOld.sh b/networking-tests/testNWOld.sh new file mode 100644 index 0000000..6714472 --- /dev/null +++ b/networking-tests/testNWOld.sh @@ -0,0 +1,14 @@ +for i in {1..100}; do + clear; echo "Add"; stack run ldgv -- interpret < ../networking-examples/add/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/add/client.ldgvnw; + sleep 0.5; + clear; echo "Simple"; stack run ldgv -- interpret < ../networking-examples/simple/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/simple/client.ldgvnw; + sleep 0.5; + clear; echo "Bidirectional"; stack run ldgv -- interpret < ../networking-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirectional/client.ldgvnw; + sleep 0.5; + clear; echo "Handoff"; stack run ldgv -- interpret < ../networking-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/client.ldgvnw; + sleep 0.5; + # clear; echo "Handoff2"; stack run ldgv -- interpret < ../networking-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff2/client.ldgvnw; + # sleep 0.5; + # clear; echo "Bidirhandoff"; stack run ldgv -- interpret < ../networking-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/client.ldgvnw; + # sleep 0.5; +done \ No newline at end of file diff --git a/networking-tests/testOftenBidirhandoff.sh b/networking-tests/testOftenBidirhandoff.sh new file mode 100644 index 0000000..4ed3faf --- /dev/null +++ b/networking-tests/testOftenBidirhandoff.sh @@ -0,0 +1,3 @@ +for i in {1..2000}; do + clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/client.ldgvnw & wait); +done \ No newline at end of file diff --git a/testOftenHandoff.sh b/networking-tests/testOftenHandoff.sh similarity index 100% rename from testOftenHandoff.sh rename to networking-tests/testOftenHandoff.sh diff --git a/testOftenHandoff2.sh b/networking-tests/testOftenHandoff2.sh similarity index 100% rename from testOftenHandoff2.sh rename to networking-tests/testOftenHandoff2.sh diff --git a/networking-tests/testOftenHandoff3.sh b/networking-tests/testOftenHandoff3.sh new file mode 100644 index 0000000..df35f25 --- /dev/null +++ b/networking-tests/testOftenHandoff3.sh @@ -0,0 +1,3 @@ +for i in {1..200000}; do + clear; echo "$i Handoff3"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff3/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff3/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff3/client.ldgvnw & wait); +done \ No newline at end of file diff --git a/networking-tests/testOftenHandoff4.sh b/networking-tests/testOftenHandoff4.sh new file mode 100644 index 0000000..97c4da1 --- /dev/null +++ b/networking-tests/testOftenHandoff4.sh @@ -0,0 +1,3 @@ +for i in {1..2000}; do + clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff4/client.ldgvnw & wait); +done \ No newline at end of file diff --git a/networking-tests/testOftenHandoff5.sh b/networking-tests/testOftenHandoff5.sh new file mode 100644 index 0000000..763a153 --- /dev/null +++ b/networking-tests/testOftenHandoff5.sh @@ -0,0 +1,3 @@ +for i in {1..2000}; do + clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff5/handoff.ldgvnw & wait); +done \ No newline at end of file diff --git a/networking-tests/testOftenHandoff6.sh b/networking-tests/testOftenHandoff6.sh new file mode 100644 index 0000000..9881943 --- /dev/null +++ b/networking-tests/testOftenHandoff6.sh @@ -0,0 +1,3 @@ +for i in {1..2000}; do + clear; echo "$i Handoff6"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff6/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff6/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff6/client.ldgvnw & wait); +done \ No newline at end of file diff --git a/networking-tests/testOftenHandoff7.sh b/networking-tests/testOftenHandoff7.sh new file mode 100644 index 0000000..fe3df5c --- /dev/null +++ b/networking-tests/testOftenHandoff7.sh @@ -0,0 +1,3 @@ +for i in {1..2000}; do + clear; echo "$i Handoff7"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff7/add.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff7/handoff.ldgvnw & wait); +done \ No newline at end of file diff --git a/testOftenRecursion.sh b/networking-tests/testOftenRecursion.sh similarity index 100% rename from testOftenRecursion.sh rename to networking-tests/testOftenRecursion.sh diff --git a/networking-tests/testRecursion.sh b/networking-tests/testRecursion.sh new file mode 100644 index 0000000..fcb64ea --- /dev/null +++ b/networking-tests/testRecursion.sh @@ -0,0 +1,2 @@ +clear; echo "Recursion"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/recursion/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/recursion/client.ldgvnw & wait); +exit; \ No newline at end of file diff --git a/networking-tests/testSimple.sh b/networking-tests/testSimple.sh new file mode 100644 index 0000000..eaa4bc5 --- /dev/null +++ b/networking-tests/testSimple.sh @@ -0,0 +1,2 @@ +clear; echo "Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/simple/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/simple/client.ldgvnw & wait); +exit; \ No newline at end of file diff --git a/testAdd.sh b/testAdd.sh deleted file mode 100644 index 2c22921..0000000 --- a/testAdd.sh +++ /dev/null @@ -1,2 +0,0 @@ -clear; echo "Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/add/server.ldgvnw & stack run ldgv -- interpret < networking-examples/add/client.ldgvnw & wait); -exit; \ No newline at end of file diff --git a/testBidirectional.sh b/testBidirectional.sh deleted file mode 100644 index 64307fe..0000000 --- a/testBidirectional.sh +++ /dev/null @@ -1,2 +0,0 @@ -clear; echo "Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirectional/client.ldgvnw & wait); -exit; \ No newline at end of file diff --git a/testBidirhandoff.sh b/testBidirhandoff.sh deleted file mode 100644 index d642f64..0000000 --- a/testBidirhandoff.sh +++ /dev/null @@ -1,2 +0,0 @@ -clear; echo "Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/client.ldgvnw & wait); -exit; \ No newline at end of file diff --git a/testHandoff.sh b/testHandoff.sh deleted file mode 100644 index a92a3a0..0000000 --- a/testHandoff.sh +++ /dev/null @@ -1,2 +0,0 @@ -clear; echo "Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff/client.ldgvnw & wait); -exit; \ No newline at end of file diff --git a/testHandoff2.sh b/testHandoff2.sh deleted file mode 100644 index 86a3a06..0000000 --- a/testHandoff2.sh +++ /dev/null @@ -1,2 +0,0 @@ -clear; echo "Handoff2"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff2/client.ldgvnw & wait); -exit; \ No newline at end of file diff --git a/testLDGVTests.sh b/testLDGVTests.sh deleted file mode 100644 index 9fc4360..0000000 --- a/testLDGVTests.sh +++ /dev/null @@ -1,21 +0,0 @@ -clear; echo "add"; stack run ldgv -- interpret < examples/add.ldgv -clear; echo "case-singleton"; stack run ldgv -- interpret < examples/case-singleton.ldgv -clear; echo "casesub"; stack run ldgv -- interpret < examples/casesub.ldgv -clear; echo "casetest"; stack run ldgv -- interpret < examples/casetest.ldgv -clear; echo "casts"; stack run ldgv -- interpret < examples/casts.ccldgv -clear; echo "depcast"; stack run ldgv -- interpret < examples/depcast.ccldgv -clear; echo "depsum"; stack run ldgv -- interpret < examples/depsum.ldgv -clear; echo "just-f2"; stack run ldgv -- interpret < examples/just-f2.ccldgv -clear; echo "just-f3"; stack run ldgv -- interpret < examples/just-f3.ccldgv -clear; echo "mymap"; stack run ldgv -- interpret < examples/mymap.gldgv -clear; echo "natsum"; stack run ldgv -- interpret < examples/natsum.ldgv -clear; echo "natsum2-new"; stack run ldgv -- interpret < examples/natsum2-new.ldgv -clear; echo "natsum2-rec"; stack run ldgv -- interpret < examples/natsum2-rec.ldgv -clear; echo "natsum2"; stack run ldgv -- interpret < examples/natsum2.ldgv -clear; echo "node"; stack run ldgv -- interpret < examples/node.ldgv -clear; echo "noderec"; stack run ldgv -- interpret < examples/noderec.ldgv -clear; echo "person"; stack run ldgv -- interpret < examples/person.gldgv -clear; echo "simple_recursion"; stack run ldgv -- interpret < examples/simple_recursion.ldgv -clear; echo "simple"; stack run ldgv -- interpret < examples/simple.ldgv -# clear; echo "tclient"; stack run ldgv -- interpret < examples/tclient.ldgv -# clear; echo "tserver"; stack run ldgv -- interpret < examples/tserver.ldgv \ No newline at end of file diff --git a/testNWCount.sh b/testNWCount.sh deleted file mode 100644 index 86b3e32..0000000 --- a/testNWCount.sh +++ /dev/null @@ -1,13 +0,0 @@ -for i in {1..10}; do - clear; echo "$i Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/add/server.ldgvnw & stack run ldgv -- interpret < networking-examples/add/client.ldgvnw & wait); - clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/simple/server.ldgvnw & stack run ldgv -- interpret < networking-examples/simple/client.ldgvnw & wait); - clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirectional/client.ldgvnw & wait); - clear; echo "$i Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff/client.ldgvnw & wait); - clear; echo "$i Handoff2"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff2/client.ldgvnw & wait); - clear; echo "$i Handoff3"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff3/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff3/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff3/client.ldgvnw & wait); - clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff4/client.ldgvnw & wait); - clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff5/handoff.ldgvnw & wait); - clear; echo "$i Handoff6"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff6/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff6/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff6/client.ldgvnw & wait); - clear; echo "$i Handoff7"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff7/add.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff7/handoff.ldgvnw & wait); - clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/client.ldgvnw & wait); -done \ No newline at end of file diff --git a/testNWCountHigh.sh b/testNWCountHigh.sh deleted file mode 100644 index 9b84f30..0000000 --- a/testNWCountHigh.sh +++ /dev/null @@ -1,13 +0,0 @@ -for i in {1..20000}; do - clear; echo "$i Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/add/server.ldgvnw & stack run ldgv -- interpret < networking-examples/add/client.ldgvnw & wait); - clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/simple/server.ldgvnw & stack run ldgv -- interpret < networking-examples/simple/client.ldgvnw & wait); - clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirectional/client.ldgvnw & wait); - clear; echo "$i Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff/client.ldgvnw & wait); - clear; echo "$i Handoff2"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff2/client.ldgvnw & wait); - clear; echo "$i Handoff3"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff3/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff3/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff3/client.ldgvnw & wait); - clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff4/client.ldgvnw & wait); - clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff5/handoff.ldgvnw & wait); - clear; echo "$i Handoff6"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff6/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff6/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff6/client.ldgvnw & wait); - clear; echo "$i Handoff7"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff7/add.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff7/handoff.ldgvnw & wait); - clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/client.ldgvnw & wait); -done \ No newline at end of file diff --git a/testNWOld.sh b/testNWOld.sh deleted file mode 100644 index 2e386aa..0000000 --- a/testNWOld.sh +++ /dev/null @@ -1,14 +0,0 @@ -for i in {1..100}; do - clear; echo "Add"; stack run ldgv -- interpret < networking-examples/add/server.ldgvnw & stack run ldgv -- interpret < networking-examples/add/client.ldgvnw; - sleep 0.5; - clear; echo "Simple"; stack run ldgv -- interpret < networking-examples/simple/server.ldgvnw & stack run ldgv -- interpret < networking-examples/simple/client.ldgvnw; - sleep 0.5; - clear; echo "Bidirectional"; stack run ldgv -- interpret < networking-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirectional/client.ldgvnw; - sleep 0.5; - clear; echo "Handoff"; stack run ldgv -- interpret < networking-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff/client.ldgvnw; - sleep 0.5; - # clear; echo "Handoff2"; stack run ldgv -- interpret < networking-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff2/client.ldgvnw; - # sleep 0.5; - # clear; echo "Bidirhandoff"; stack run ldgv -- interpret < networking-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/client.ldgvnw; - # sleep 0.5; -done \ No newline at end of file diff --git a/testOftenBidirhandoff.sh b/testOftenBidirhandoff.sh deleted file mode 100644 index 04c8c0a..0000000 --- a/testOftenBidirhandoff.sh +++ /dev/null @@ -1,3 +0,0 @@ -for i in {1..100}; do - clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < networking-examples/bidirhandoff/client.ldgvnw & wait); -done \ No newline at end of file diff --git a/testOftenHandoff3.sh b/testOftenHandoff3.sh deleted file mode 100644 index 7133e08..0000000 --- a/testOftenHandoff3.sh +++ /dev/null @@ -1,3 +0,0 @@ -for i in {1..200000}; do - clear; echo "$i Handoff3"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff3/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff3/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff3/client.ldgvnw & wait); -done \ No newline at end of file diff --git a/testOftenHandoff4.sh b/testOftenHandoff4.sh deleted file mode 100644 index 2a20e37..0000000 --- a/testOftenHandoff4.sh +++ /dev/null @@ -1,3 +0,0 @@ -for i in {1..2000}; do - clear; echo "$i Handoff4"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff4/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff4/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff4/client.ldgvnw & wait); -done \ No newline at end of file diff --git a/testOftenHandoff5.sh b/testOftenHandoff5.sh deleted file mode 100644 index 12aebcc..0000000 --- a/testOftenHandoff5.sh +++ /dev/null @@ -1,3 +0,0 @@ -for i in {1..2000}; do - clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff5/handoff.ldgvnw & wait); -done \ No newline at end of file diff --git a/testOftenHandoff6.sh b/testOftenHandoff6.sh deleted file mode 100644 index 489f2bf..0000000 --- a/testOftenHandoff6.sh +++ /dev/null @@ -1,3 +0,0 @@ -for i in {1..2000}; do - clear; echo "$i Handoff6"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff6/server.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff6/handoff.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff6/client.ldgvnw & wait); -done \ No newline at end of file diff --git a/testOftenHandoff7.sh b/testOftenHandoff7.sh deleted file mode 100644 index f6db69a..0000000 --- a/testOftenHandoff7.sh +++ /dev/null @@ -1,3 +0,0 @@ -for i in {1..2000}; do - clear; echo "$i Handoff7"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/handoff7/add.ldgvnw & stack run ldgv -- interpret < networking-examples/handoff7/handoff.ldgvnw & wait); -done \ No newline at end of file diff --git a/testRecursion.sh b/testRecursion.sh deleted file mode 100644 index d9a1b84..0000000 --- a/testRecursion.sh +++ /dev/null @@ -1,2 +0,0 @@ -clear; echo "Recursion"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/recursion/server.ldgvnw & stack run ldgv -- interpret < networking-examples/recursion/client.ldgvnw & wait); -exit; \ No newline at end of file diff --git a/testSimple.sh b/testSimple.sh deleted file mode 100644 index 6e1e681..0000000 --- a/testSimple.sh +++ /dev/null @@ -1,2 +0,0 @@ -clear; echo "Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < networking-examples/simple/server.ldgvnw & stack run ldgv -- interpret < networking-examples/simple/client.ldgvnw & wait); -exit; \ No newline at end of file From 478171b81685ee46612725e8708b20ac3aca083e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 6 Mar 2023 15:24:00 +0100 Subject: [PATCH 186/229] Added a Readme --- README-networking.md | 99 +++++++++++++++++++++++++++++++++++ networking-tests/testNW.sh | 8 --- networking-tests/testNWOld.sh | 14 ----- 3 files changed, 99 insertions(+), 22 deletions(-) create mode 100644 README-networking.md delete mode 100644 networking-tests/testNW.sh delete mode 100644 networking-tests/testNWOld.sh diff --git a/README-networking.md b/README-networking.md new file mode 100644 index 0000000..0b6e700 --- /dev/null +++ b/README-networking.md @@ -0,0 +1,99 @@ +# How to try LDGVNW for yourself + +Using LDGVNW is a little more difficult than simply starting a single program. In addition to the requirements of LDGV you also need a network connected via IPv4, should this network span more than one device the IP-addresses within the LDGVNW programs need to be altered in addition to that. The current version of LDGVNW was tested on Fedora 36 and MacOS 13.2 and should work on every recent Linux or MacOS machine, it is unknown whether LDGVNW works on Windows machines. + +To run a LDGVNW example, found in the networking-examples folder, each program in the example folder need to be run at once. So if you would like to start the "handoff" example you would run following commands in different terminals or on different machines: + +- stack run ldgv -- interpret networking-examples/handoff/client.ldgvnw +- stack run ldgv -- interpret networking-examples/handoff/server.ldgvnw +- stack run ldgv -- interpret networking-examples/handoff/handoff.ldgbnw + +The order in which these commands are executed does not matter. + +To test all the different testcases in a easier way, they can be automatically run, with the scrips provided in the networking-tests folder. Simply running one of these scripts will run the whole testcase at once. +The testNW* scripts contain all the tests, except for the recursion test. + + +# An Introduction to LDGVNWs Networking Architecture + +LDGVNW adds networking capabilities to LDGV. To enable this, LDGVNW adds 2 new commands: + +- **accept \ \** +- **connect \ \ \ \** + +The **accept** command requires an integer as a port for others to connect, and a type that will be required of a connecting connection. Once a communication partner connects with a desired type, the **accept** command will return a **VChan**. +The **connect** command also requires an integer port and a desired type, but also needs to specify a string for the address of the connection partner as well as an integer for the port of the connection partner. Just like with the **accept** command, the **connect** command will return a **VChan** once a connection has been established. +Important to note is that, with the current implementation, only IPv4 addresses are supported. IPv6 and Unix domain sockets could be supported in the future with a relatively low effort. + +## The Logical Communication Architecture + +### Messages and Responses +In LDGVNW there are 7 possible **Messages** and 4 possible **Responses**. +The messages are: + +- **Introduce \ \ \ \** +- **NewValue \ \ \** +- **RequestValue \ \** +- **AcknowledgeValue \ \** +- **NewPartnerAddress \ \ \** +- **AcknowledgePartnerAddress \ \** +- **Disconnect \** + +With possible responses: + +- **Redirect \ \** +- **Okay** +- **OkayIntroduce \** +- **Wait** + +Typing for the attributes: + +- **UserID** A unique string, used to identify the logical communication partner +- **ConnectionID** A unique string, used to identify the physical communication partner +- **Port** A string containing the number of a port +- **Address** A string containing the IPv4 or URL of a communication partner +- **Value** The serialization of the sent Value +- **Value Index** A integer containing the index of a Value +- **Type Name** The serialization of the TName Type of the desired Type +- **Type Structure** The serialization of the type structure of the desired Type + +The **UserID** is a unique identifier, so a message can be associated with the correct communication partner. + +### Establishing a new Connection +As soon as **B** opens up their port with the **accept** command. **A** can **connect**, by sending a **Introduce** message to **B**. This message contains the unique ID of **A**, **A**s port as well as the name and structure of the desired communication **Type**. **B** then answers with a **OkayIntroduce** response, sharing their own unique ID with **A**. Following that **A** and **B** can **send** and **recv** values analog to **Channels** created with the **new** command. + +### Sending messages over a Connection +When communication partner **A** executes a send instruction to **send** Value **V** to **B**, **A** first analyses **V**. Should **V** be or contain a **Channel** **C**, receiving messages for **C** will be redirected to the address of **B** and the state of **C** will be converted to a serializable form **CS**. After that **V** will be serialized to **VS**, which will be written to **A**s write-buffer and sent to **B** via a **NewValue** message. Upon recieving **VS** as **B** with the **recv** instruction, **VS** will be deserialized to **VD**. Should **VD** contain a serialized form of a **Channel** this **Channel** will be convered to a regular **Channel** **CD** and the communication partner of **CD** will be informed of the communication partner change. After this **B** sends an acknowledgment (**AcknowledgeValue** message) back to **A**, which finalizes the sending of **V**, by **A** removing **V** out of its write-buffer. + +### Responding to Messages +With the exception of the **Introduce** message, every message should be answered with a **Okay** response. Exceptions to that are **Redirect** responses, which are used when a message is sent to an outdated address or **Wait** responses which are sent when a message cannot be handled at the current moment. This can happen when the communication partner is already handling a message in a critical section, or a communication partner is currently in the progress of sending the **Channel** which the message is sent to. + +### Informing communication partners of a communication partner change +If a **Channel** **C** got sent over a network connection to **A**, the new communication partner **B** needs to be notified of this change. To archive this **A** sends a **NewParterAddress** message to **B**. This message contains the server port of **A** and the new ConnectionID **AC** for **A**. **B** then replies with a **AcknowledgeParterAddress** message, repeating **AC**. As soon as the address is established **C** is considered being successfully received by **A**. + + +### Shutting down after completing all the instructions +After **A** finishes the interpretation of their program, **A** waits until all messages it sent were acknowledged by their communication partners. After that **A** sends a **Disconnect** message to all its peers. The **Disconnect** message is needed to avoid rewriting a large portion of the interpreter to annotate each expression with their associated output **Types**. Should the **Disconnect** message not exist, it would be theoretically possible to send a **Unit=Type** of an exhausted **Channel** to another communication partner. The recipient would now be unknowing whether their new communication partner were still online. + +### A communication example + +## Serializing and Sending Messages +The logical messages are serialized first, then are sent either using a fast protocol which reuses existing connections or a stateless protocol, which was primary used during development as a fallback when the fest protocol wasn't working, yet. + +### Serialization +Messages and Responses in LDGVNW are serialized into ASCII-Strings and follow usually the form of the name of the Message, Value, etc. followed by their arguments in brackets. For instance the message **NewValue \ \<2> \** would be translated to **NNewValue (String:"abcd1234") (Int:2) (VInt (Int:42))** + +### Stateless Protocol +The stateless protocol allows to directly send serialized logical messages, by establishing a new connection, sending the serialized message, waiting for a response and disconnecting afterward. By always creating new connections it can be assured that every Message gets their correct response, but establishing a new TCP connection every time a message is sent also causes a huge performance penalty. + +### Fast Protocol +The fast protocol saves a once created TCP connection and reuses it as long as it stays open. Since LDGVNW uses multiple threads to send Messages this can lead to Messages and Responses to be mismatched. To avoid this each Message and Response is wrapped in a ConversationSession. + +- **ConversationMessage \ \** +- **ConversationResponse \ \** +- **ConversationCloseAll** + +The ConversationID is a random string, selected by the sender of the message and copied by the respondent. **ConversationCloseAll**} is used when one party wants to close all connections to a peer, signaling to their peer that they would need to establish a new connection if they would like to talk to this port again. + +## Compatibility between Internal and External Channels + diff --git a/networking-tests/testNW.sh b/networking-tests/testNW.sh deleted file mode 100644 index cdaef57..0000000 --- a/networking-tests/testNW.sh +++ /dev/null @@ -1,8 +0,0 @@ -for i in {1..100}; do - bash testAdd.sh; - bash testSimple.sh; - bash testBidirectional.sh; - bash testHandoff.sh; - bash testHandoff2.sh; - bash testBidirhandoff.sh; -done \ No newline at end of file diff --git a/networking-tests/testNWOld.sh b/networking-tests/testNWOld.sh deleted file mode 100644 index 6714472..0000000 --- a/networking-tests/testNWOld.sh +++ /dev/null @@ -1,14 +0,0 @@ -for i in {1..100}; do - clear; echo "Add"; stack run ldgv -- interpret < ../networking-examples/add/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/add/client.ldgvnw; - sleep 0.5; - clear; echo "Simple"; stack run ldgv -- interpret < ../networking-examples/simple/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/simple/client.ldgvnw; - sleep 0.5; - clear; echo "Bidirectional"; stack run ldgv -- interpret < ../networking-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirectional/client.ldgvnw; - sleep 0.5; - clear; echo "Handoff"; stack run ldgv -- interpret < ../networking-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/client.ldgvnw; - sleep 0.5; - # clear; echo "Handoff2"; stack run ldgv -- interpret < ../networking-examples/handoff2/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff2/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff2/client.ldgvnw; - # sleep 0.5; - # clear; echo "Bidirhandoff"; stack run ldgv -- interpret < ../networking-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/client.ldgvnw; - # sleep 0.5; -done \ No newline at end of file From e6dfd3ee8843f7248c8956c9d4ba4b2721f2098d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 6 Mar 2023 18:35:41 +0100 Subject: [PATCH 187/229] Added new testcase 120 okay runs. Stability needs to be excessively tested for this change though, since I had to resolve a big oversight in my program --- networking-examples/handoff8/add.ldgvnw | 13 ++++ networking-examples/handoff8/handoff.ldgvnw | 24 ++++++ networking-tests/testNWCount.sh | 1 + networking-tests/testNWCountHigh.sh | 1 + networking-tests/testOftenHandoff8.sh | 3 + src/Config.hs | 4 +- src/Networking/Incoming.hs | 85 ++++++++++++++++++--- src/Networking/NetworkBuffer.hs | 4 + src/Networking/Outgoing.hs | 27 ++++--- 9 files changed, 139 insertions(+), 23 deletions(-) create mode 100644 networking-examples/handoff8/add.ldgvnw create mode 100644 networking-examples/handoff8/handoff.ldgvnw create mode 100644 networking-tests/testOftenHandoff8.sh diff --git a/networking-examples/handoff8/add.ldgvnw b/networking-examples/handoff8/add.ldgvnw new file mode 100644 index 0000000..ba29c78 --- /dev/null +++ b/networking-examples/handoff8/add.ldgvnw @@ -0,0 +1,13 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit +type SendAdd : ! ~ssn = !SendInt. !(dualof SendInt). Unit + +val main : Unit +val main = + let = (new SendInt) in + let con = (connect 4100 SendAdd "127.0.0.1" 4000) in + let con2 = (send con) a in + let con3 = (send con2) b in + () diff --git a/networking-examples/handoff8/handoff.ldgvnw b/networking-examples/handoff8/handoff.ldgvnw new file mode 100644 index 0000000..bf009e3 --- /dev/null +++ b/networking-examples/handoff8/handoff.ldgvnw @@ -0,0 +1,24 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit +type SendAdd : ! ~ssn = !SendInt. !(dualof SendInt). Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let y = ((send x) 42) in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val main : Int +val main = + let con = (accept 4000 (dualof SendAdd)) in + let = recv con in + let = recv con2 in + let a1 = fork (send2 a) in + add2 b + diff --git a/networking-tests/testNWCount.sh b/networking-tests/testNWCount.sh index 80e1db9..81f0aea 100644 --- a/networking-tests/testNWCount.sh +++ b/networking-tests/testNWCount.sh @@ -9,5 +9,6 @@ for i in {1..10}; do clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff5/handoff.ldgvnw & wait); clear; echo "$i Handoff6"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff6/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff6/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff6/client.ldgvnw & wait); clear; echo "$i Handoff7"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff7/add.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff7/handoff.ldgvnw & wait); + clear; echo "$i Handoff8"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff8/add.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff8/handoff.ldgvnw & wait); clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/client.ldgvnw & wait); done \ No newline at end of file diff --git a/networking-tests/testNWCountHigh.sh b/networking-tests/testNWCountHigh.sh index bf8427b..f3aa3db 100644 --- a/networking-tests/testNWCountHigh.sh +++ b/networking-tests/testNWCountHigh.sh @@ -9,5 +9,6 @@ for i in {1..20000}; do clear; echo "$i Handoff5"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff5/add.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff5/handoff.ldgvnw & wait); clear; echo "$i Handoff6"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff6/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff6/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff6/client.ldgvnw & wait); clear; echo "$i Handoff7"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff7/add.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff7/handoff.ldgvnw & wait); + clear; echo "$i Handoff8"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff8/add.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff8/handoff.ldgvnw & wait); clear; echo "$i Bidirhandoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/bidirhandoff/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/serverhandoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/clienthandoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirhandoff/client.ldgvnw & wait); done \ No newline at end of file diff --git a/networking-tests/testOftenHandoff8.sh b/networking-tests/testOftenHandoff8.sh new file mode 100644 index 0000000..0197163 --- /dev/null +++ b/networking-tests/testOftenHandoff8.sh @@ -0,0 +1,3 @@ +for i in {1..2000}; do + clear; echo "$i Handoff8"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff8/add.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff8/handoff.ldgvnw & wait); +done \ No newline at end of file diff --git a/src/Config.hs b/src/Config.hs index 80a6a6b..c684721 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -13,8 +13,8 @@ data DebugLevel = DebugNone | DebugNetwork | DebugAll debugLevel :: DebugLevel -- debugLevel = DebugAll --- debugLevel = DebugNetwork -debugLevel = DebugNone +debugLevel = DebugNetwork +-- debugLevel = DebugNone trace :: String -> a -> a trace s a | debugLevel > DebugNetwork = D.trace s a diff --git a/src/Networking/Incoming.hs b/src/Networking/Incoming.hs index 5802d06..e6abddb 100644 --- a/src/Networking/Incoming.hs +++ b/src/Networking/Incoming.hs @@ -117,6 +117,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria clientlistraw <- MVar.takeMVar clientlist MVar.putMVar clientlist $ clientlistraw ++ [(userid, (synname, syntype))] -- We must not write clients into the clientlist before adding them to the networkconnectionmap + _ -> do serial <- NSerialize.serialize deserialmessages recievedNetLog message $ "Error unsupported networkmessage: "++ serial @@ -139,26 +140,61 @@ setPartnerHostAddress address = modifyVChansStatic (handleSerial address) VChanSerial r w p o (if hostname == "" then address else hostname, port, partnerID) _ -> input -- return input -waitUntilContactedNewPeers :: NMC.ActiveConnections -> Value -> String -> IO () -waitUntilContactedNewPeers activeCons input ownport = do - contactedPeers <- contactNewPeers activeCons ownport input +waitUntilContactedNewPeers :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> Value -> String -> IO () +waitUntilContactedNewPeers vchansmvar activeCons ownNC input ownport = do + contactedPeers <- contactNewPeers vchansmvar activeCons ownport ownNC input unless contactedPeers $ do threadDelay 50000 - waitUntilContactedNewPeers activeCons input ownport + waitUntilContactedNewPeers vchansmvar activeCons ownNC input ownport -contactNewPeers :: NMC.ActiveConnections -> String -> Value -> IO Bool -contactNewPeers activeCons ownport = searchVChans (handleVChan activeCons ownport) True (&&) +contactNewPeers :: VChanConnections -> NMC.ActiveConnections -> String -> NetworkConnection Value -> Value -> IO Bool +contactNewPeers vchansmvar activeCons ownport ownNC = searchVChans (handleVChan activeCons ownport ownNC) True (&&) where - handleVChan :: NMC.ActiveConnections -> String -> Value -> IO Bool - handleVChan activeCons ownport input = case input of + handleVChan :: NMC.ActiveConnections -> String -> NetworkConnection Value -> Value -> IO Bool + handleVChan activeCons ownport ownNC input = case input of VChan nc bool -> do connectionState <- MVar.readMVar $ ncConnectionState nc case connectionState of Emulated {} -> return True _ -> do if csConfirmedConnection connectionState then return True else do - NO.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) 0 - return False + -- Check whether their partner is also registered and connected on this instance, if so convert the connection into a emulated one + vchanconnections <- MVar.readMVar vchansmvar + let userid = ncOwnUserID nc + let partnerid = ncPartnerUserID nc + let mbypartner = Map.lookup userid vchanconnections + case mbypartner of + Just partner -> do + -- Their partner is registered in this instance. Now we have to figure out whether this is till current and we can start emulating the connection + SSem.wait (ncHandlingIncomingMessage partner) + connectionstate <- MVar.takeMVar $ ncConnectionState partner + case connectionState of + Connected {} -> do + -- Reemulate them + partConID <- RandomID.newRandomID + ownConID <- RandomID.newRandomID + MVar.putMVar (ncConnectionState partner) $ Emulated ownConID partConID True + _ <- MVar.takeMVar $ ncConnectionState nc + MVar.putMVar (ncConnectionState nc) $ Emulated partConID ownConID True + SSem.signal (ncHandlingIncomingMessage partner) + return True + _ -> do + -- Nothing to do here, we no longer own the partner + MVar.putMVar (ncConnectionState partner) connectionState + SSem.signal (ncHandlingIncomingMessage partner) + sendSuccess <- NO.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) $ -2 + if sendSuccess then return False else do + threadDelay 100000 + putStrLn "Trying to lookup future messages" + futureRecieveContainsPartner ownNC partnerid + Nothing -> do + -- Their partner isnt registered in this instance + sendSuccess <- NO.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) $ -2 + if sendSuccess then return False else do + threadDelay 100000 + putStrLn "Trying to lookup future messages" + futureRecieveContainsPartner ownNC partnerid + -- return False _ -> return True hostaddressTypeToString :: HostAddress -> String @@ -218,7 +254,7 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do case mbyUnclean of Just unclean -> do val <- replaceVChanSerial activeCons vchanconsvar $ fst unclean - waitUntilContactedNewPeers activeCons val ownport + waitUntilContactedNewPeers vchanconsvar activeCons networkconnection val ownport -- msgCount <- DC.unreadMessageStart $ ncRead networkconnection connectionState <- MVar.readMVar $ ncConnectionState networkconnection case connectionState of @@ -245,4 +281,29 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do recieveValueInternal 100 vchanconsvar activeCons networkconnection ownport else do threadDelay 5000 - recieveValueInternal (count-1) vchanconsvar activeCons networkconnection ownport \ No newline at end of file + recieveValueInternal (count-1) vchanconsvar activeCons networkconnection ownport + +valueContainsPartner :: String -> Value -> IO Bool +valueContainsPartner partner = searchVChans (handleSerial partner) False (||) + where + handleSerial :: String -> Value -> IO Bool + handleSerial partner value = case value of + VChanSerial r w p o c -> do + putStrLn $ "Looking for: " ++ partner ++ " p: " ++ p ++ " o: " ++ o + return (partner == o) + _ -> return False + +futureRecieveContainsPartner :: NetworkConnection Value -> String -> IO Bool +futureRecieveContainsPartner = fRCPInternal 0 + where + fRCPInternal count nc partner = do + putStrLn $ "Trying to read at: " ++ show count + mbyVal <- NB.tryGetAtRelativeNB (ncRead nc) count + case mbyVal of + Nothing -> do + putStrLn $ "Index " ++ show count ++ " is empty" + return False + Just value -> do + putStrLn $ "Looking up index " ++ show count + containsPartner <- valueContainsPartner partner value + if containsPartner then return True else fRCPInternal (count+1) nc partner diff --git a/src/Networking/NetworkBuffer.hs b/src/Networking/NetworkBuffer.hs index 64451f0..d80f1bc 100644 --- a/src/Networking/NetworkBuffer.hs +++ b/src/Networking/NetworkBuffer.hs @@ -51,6 +51,10 @@ tryGetAtNB nb count = SSem.withSem (working nb) $ do offset <- readMVar $ bufferOffset nb tryGetAt (buffer nb) (count-offset) +tryGetAtRelativeNB :: NetworkBuffer a -> Int -> IO (Maybe a) +tryGetAtRelativeNB nb count = SSem.withSem (working nb) $ do + tryGetAt (buffer nb) count + tryTake :: NetworkBuffer a -> IO (Maybe (a, Int)) tryTake nb = SSem.withSem (working nb) $ modifyMVar (bufferOffset nb) (\offset -> do mbyTakeValue <- tryTakeBuffer (buffer nb) diff --git a/src/Networking/Outgoing.hs b/src/Networking/Outgoing.hs index 9ad071c..0c7fbb8 100644 --- a/src/Networking/Outgoing.hs +++ b/src/Networking/Outgoing.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} module Networking.Outgoing where @@ -85,6 +86,11 @@ sendNetworkMessage activeCons networkconnection message resendOnError = do let port = csPort connectionstate tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError +-- ResendOnError gives the number of times a value might be resent when a error occures +-- There are three special cases +-- (-1) will send indefinitely until it succedes +-- (-2) will not wait and only act on redirect messages (wait messages and failed connections wont result in reattempting sending the message) +-- For numbers n smaller than -2 it will wait for abs(n)-2 times tryToSendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> String -> String -> Message -> Int -> IO Bool tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError = do serializedMessage <- NSerialize.serialize message @@ -110,20 +116,23 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen Okay -> do sendingNetLog serializedMessage "Message okay" return True - Redirect host port -> do - sendingNetLog serializedMessage "Communication partner changed address, resending" - tryToSendNetworkMessage activeCons networkconnection host port message resendOnError - Wait -> do - sendingNetLog serializedMessage "Communication out of sync lets wait!" - threadDelay 1000000 - tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError + Redirect host port -> do + sendingNetLog serializedMessage "Communication partner changed address, resending" + tryToSendNetworkMessage activeCons networkconnection host port message if resendOnError < -2 then resendOnError +1 else resendOnError + Wait -> if resendOnError /= (-2) then do + sendingNetLog serializedMessage "Communication out of sync lets wait!" + threadDelay 1000000 + tryToSendNetworkMessage activeCons networkconnection hostname port message if resendOnError < -2 then resendOnError +1 else resendOnError + else do + sendingNetLog serializedMessage "Communication out of sync lets wait!, sending failed" + return False _ -> do sendingNetLog serializedMessage "Unknown communication error" return False Nothing -> do sendingNetLog serializedMessage "Error when recieving response" - if resendOnError /= 0 then do + if resendOnError /= 0 && resendOnError <= (-2) then do connectionState <- MVar.readMVar $ ncConnectionState networkconnection case connectionState of Connected updatedhost updatedport _ _ _ -> do @@ -205,7 +214,7 @@ setRedirectRequests vchanconmvar newhost newport ownport = searchVChans (handleV case mbypartner of Just partner -> do MVar.putMVar (ncConnectionState nc) $ RedirectRequest "" ownport newhost newport partConID ownConID confirmed -- Setting this to 127.0.0.1 is a temporary hack - oldconectionstatePartner <- MVar.takeMVar $ ncConnectionState partner + oldconnectionstatePartner <- MVar.takeMVar $ ncConnectionState partner MVar.putMVar (ncConnectionState partner) $ Connected newhost newport partConID ownConID confirmed Nothing -> do MVar.putMVar (ncConnectionState nc) oldconnectionstate From 3b45a83e8ebc43a1c25e12162501fe2fade9137e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 6 Mar 2023 19:56:23 +0100 Subject: [PATCH 188/229] Fixed the patch for handoff8 for other situations I hope this is still stable. This needs to be reverified. I need to add a check which instantly appends channels from incoming messages. So I don't have to use this hotfix --- src/Networking/Incoming.hs | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/src/Networking/Incoming.hs b/src/Networking/Incoming.hs index e6abddb..6835dd5 100644 --- a/src/Networking/Incoming.hs +++ b/src/Networking/Incoming.hs @@ -186,14 +186,14 @@ contactNewPeers vchansmvar activeCons ownport ownNC = searchVChans (handleVChan if sendSuccess then return False else do threadDelay 100000 putStrLn "Trying to lookup future messages" - futureRecieveContainsPartner ownNC partnerid + futureRecieveFromAllContainsPartner vchansmvar ownNC partnerid Nothing -> do -- Their partner isnt registered in this instance sendSuccess <- NO.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) $ -2 if sendSuccess then return False else do threadDelay 100000 putStrLn "Trying to lookup future messages" - futureRecieveContainsPartner ownNC partnerid + futureRecieveFromAllContainsPartner vchansmvar ownNC partnerid -- return False _ -> return True @@ -293,6 +293,21 @@ valueContainsPartner partner = searchVChans (handleSerial partner) False (||) return (partner == o) _ -> return False +futureRecieveFromAllContainsPartner :: VChanConnections -> NetworkConnection Value -> String -> IO Bool +futureRecieveFromAllContainsPartner vchansvar nc partner = do + own <- futureRecieveContainsPartner nc partner + if own then return True else do + consmap <- MVar.readMVar vchansvar + let cons = Map.elems consmap + fRFACPInternal cons partner + where + fRFACPInternal :: [NetworkConnection Value] -> String -> IO Bool + fRFACPInternal [] partner = return False + fRFACPInternal (x:xs) partner = do + containsPartner <- futureRecieveContainsPartner x partner + if containsPartner then return True else fRFACPInternal xs partner + + futureRecieveContainsPartner :: NetworkConnection Value -> String -> IO Bool futureRecieveContainsPartner = fRCPInternal 0 where From 71d7750af3b74a412ae53db29811d0b5920cb0d4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 7 Mar 2023 11:51:30 +0100 Subject: [PATCH 189/229] Major rewrite of handling incoming and outgoing messages This handles the fix for handoff 8 in a way more elegant way. It is unknown whether this is stable --- src/Interpreter.hs | 2 +- src/Networking/Incoming.hs | 192 +++++++++++++++++++--------- src/Networking/NetworkConnection.hs | 23 +++- src/Networking/Outgoing.hs | 2 +- 4 files changed, 149 insertions(+), 70 deletions(-) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index c70297c..b5fb1fd 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -261,7 +261,7 @@ interpretApp _ (VSend v@(VChan cc usedmvar)) w = do socketsraw <- liftIO $ MVar.readMVar sockets let port = show $ head $ Map.keys socketsraw C.traceNetIO $ "Trying to send: " ++ show w - liftIO $ NO.sendValue vchanconnections activeConnections cc w port (-1) + liftIO $ NO.sendValue vchanconnections activeConnections cc w port (-2) C.traceNetIO $ "Sent: " ++ show w -- Disable old VChan liftIO $ disableOldVChan v diff --git a/src/Networking/Incoming.hs b/src/Networking/Incoming.hs index 6835dd5..28a4b6a 100644 --- a/src/Networking/Incoming.hs +++ b/src/Networking/Incoming.hs @@ -37,67 +37,79 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria case Map.lookup userid netcons of Just ncToPartner -> do recievedNetLog message $ "Recieved message as: " ++ ncOwnUserID ncToPartner ++ " (" ++ ownport ++ ") from: " ++ ncPartnerUserID ncToPartner - busy <- SSem.tryWait $ ncHandlingIncomingMessage ncToPartner - case busy of - Just num -> do - constate <- MVar.readMVar $ ncConnectionState ncToPartner - reply <- case constate of - RedirectRequest _ _ host port _ _ _ -> do - recievedNetLog message $ "Found redirect request for: " ++ userid - recievedNetLog message $ "Send redirect to:" ++ host ++ ":" ++ port - SSem.signal $ ncHandlingIncomingMessage ncToPartner - NC.sendResponse hdl (Messages.Redirect host port) - Connected {} -> case deserialmessages of - NewValue userid count val -> do - -- DC.lockInterpreterReads (ncRead ncToPartner) - success <- NB.writeIfNext (ncRead ncToPartner) count $ setPartnerHostAddress clientHostaddress val + ncIsReady <- isReadyForUse ncToPartner + if ncIsReady then do + busy <- SSem.tryWait $ ncHandlingIncomingMessage ncToPartner + case busy of + Just num -> do + constate <- MVar.readMVar $ ncConnectionState ncToPartner + reply <- case constate of + RedirectRequest _ _ host port _ _ _ -> do + recievedNetLog message $ "Found redirect request for: " ++ userid + recievedNetLog message $ "Send redirect to:" ++ host ++ ":" ++ port SSem.signal $ ncHandlingIncomingMessage ncToPartner - if success then recievedNetLog message "Message written to Channel" else recievedNetLog message "Message not correct" - NC.sendResponse hdl Messages.Okay - recievedNetLog message "Sent okay" - -- DC.unlockInterpreterReads (ncRead ncToPartner) - RequestValue userid count -> do - SSem.signal $ ncHandlingIncomingMessage ncToPartner - NC.sendResponse hdl Messages.Okay - mbyval <- NB.tryGetAtNB (NCon.ncWrite ncToPartner) count - Data.Maybe.maybe (return False) (\val -> NO.sendNetworkMessage activeCons ncToPartner (Messages.NewValue (ncOwnUserID ncToPartner) count val) 0) mbyval - return () - AcknowledgeValue userid count -> do - NC.sendResponse hdl Messages.Okay -- This okay is needed here to fix a race-condition with disconnects being faster than the okay - -- NB.serialize (ncWrite ncToPartner) >>= \x -> Config.traceNetIO $ "Online before acknowlegment: " ++ show x - NB.updateAcknowledgements (NCon.ncWrite ncToPartner) count - SSem.signal $ ncHandlingIncomingMessage ncToPartner - NewPartnerAddress userid port connectionID -> do - recievedNetLog message $ "Trying to change the address to: " ++ clientHostaddress ++ ":" ++ port - NCon.changePartnerAddress ncToPartner clientHostaddress port connectionID - SSem.signal $ ncHandlingIncomingMessage ncToPartner - NC.sendResponse hdl Messages.Okay + NC.sendResponse hdl (Messages.Redirect host port) + Connected {} -> case deserialmessages of + NewValue userid count val -> do + -- DC.lockInterpreterReads (ncRead ncToPartner) + let fixedPartnerHostAddress = setPartnerHostAddress clientHostaddress val + success <- NB.writeIfNext (ncRead ncToPartner) count fixedPartnerHostAddress + if success then do + recievedNetLog message "Inserting VChans into VChanCons" + insertVChansIntoVChanCons mvar False fixedPartnerHostAddress + recievedNetLog message "Message written to Channel" + else recievedNetLog message "Message not correct" + SSem.signal $ ncHandlingIncomingMessage ncToPartner + NC.sendResponse hdl Messages.Okay + recievedNetLog message "Sent okay" + -- DC.unlockInterpreterReads (ncRead ncToPartner) + RequestValue userid count -> do + SSem.signal $ ncHandlingIncomingMessage ncToPartner + NC.sendResponse hdl Messages.Okay + mbyval <- NB.tryGetAtNB (NCon.ncWrite ncToPartner) count + Data.Maybe.maybe (return False) (\val -> NO.sendNetworkMessage activeCons ncToPartner (Messages.NewValue (ncOwnUserID ncToPartner) count val) 0) mbyval + return () + AcknowledgeValue userid count -> do + NC.sendResponse hdl Messages.Okay -- This okay is needed here to fix a race-condition with disconnects being faster than the okay + -- NB.serialize (ncWrite ncToPartner) >>= \x -> Config.traceNetIO $ "Online before acknowlegment: " ++ show x + NB.updateAcknowledgements (NCon.ncWrite ncToPartner) count + SSem.signal $ ncHandlingIncomingMessage ncToPartner + NewPartnerAddress userid port connectionID -> do + recievedNetLog message $ "Trying to change the address to: " ++ clientHostaddress ++ ":" ++ port + NCon.changePartnerAddress ncToPartner clientHostaddress port connectionID + recievedNetLog message $ "Successfully changed address to: " ++ clientHostaddress ++ ":" ++ port + SSem.signal $ ncHandlingIncomingMessage ncToPartner + NC.sendResponse hdl Messages.Okay - NO.sendNetworkMessage activeCons ncToPartner (Messages.AcknowledgePartnerAddress (ncOwnUserID ncToPartner) connectionID) 0 - return () - AcknowledgePartnerAddress userid connectionID -> do - conConfirmed <- NCon.confirmConnectionID ncToPartner connectionID - SSem.signal $ ncHandlingIncomingMessage ncToPartner - if conConfirmed then NC.sendResponse hdl Messages.Okay else NC.sendResponse hdl Messages.Error - Disconnect userid -> do - NC.sendResponse hdl Messages.Okay - NCon.disconnectFromPartner ncToPartner - SSem.signal $ ncHandlingIncomingMessage ncToPartner - return () + successSendingResponse <- NO.sendNetworkMessage activeCons ncToPartner (Messages.AcknowledgePartnerAddress (ncOwnUserID ncToPartner) connectionID) $ -2 + when successSendingResponse $ recievedNetLog message "Successfully acknowledged message" + return () + AcknowledgePartnerAddress userid connectionID -> do + conConfirmed <- NCon.confirmConnectionID ncToPartner connectionID + SSem.signal $ ncHandlingIncomingMessage ncToPartner + if conConfirmed then NC.sendResponse hdl Messages.Okay else NC.sendResponse hdl Messages.Error + Disconnect userid -> do + NC.sendResponse hdl Messages.Okay + NCon.disconnectFromPartner ncToPartner + SSem.signal $ ncHandlingIncomingMessage ncToPartner + return () + _ -> do + serial <- NSerialize.serialize deserialmessages + recievedNetLog message $ "Error unsupported networkmessage: "++ serial + SSem.signal $ ncHandlingIncomingMessage ncToPartner + NC.sendResponse hdl Messages.Okay _ -> do - serial <- NSerialize.serialize deserialmessages - recievedNetLog message $ "Error unsupported networkmessage: "++ serial + recievedNetLog message "Network Connection is in a illegal state!" SSem.signal $ ncHandlingIncomingMessage ncToPartner NC.sendResponse hdl Messages.Okay - _ -> do - recievedNetLog message "Network Connection is in a illegal state!" - SSem.signal $ ncHandlingIncomingMessage ncToPartner - NC.sendResponse hdl Messages.Okay - return reply - Nothing -> do - recievedNetLog message "Message cannot be handled at the moment! Sending wait response" - SSem.signal $ ncHandlingIncomingMessage ncToPartner - NC.sendResponse hdl Messages.Wait + return reply + Nothing -> do + recievedNetLog message "Message cannot be handled at the moment! Sending wait response" + SSem.signal $ ncHandlingIncomingMessage ncToPartner + NC.sendResponse hdl Messages.Wait + else do + recievedNetLog message "Found a networkconnection, but it's not ready to be used yet" + NC.sendResponse hdl Messages.Wait Nothing -> do recievedNetLog message "Recieved message from unknown connection" @@ -176,24 +188,34 @@ contactNewPeers vchansmvar activeCons ownport ownNC = searchVChans (handleVChan MVar.putMVar (ncConnectionState partner) $ Emulated ownConID partConID True _ <- MVar.takeMVar $ ncConnectionState nc MVar.putMVar (ncConnectionState nc) $ Emulated partConID ownConID True + {-setReadyForUse partner True + Config.traceNetIO $ "Set: " ++ ncOwnUserID partner ++ " ready for use" + setReadyForUse nc True + Config.traceNetIO $ "Set: " ++ ncOwnUserID nc ++ " ready for use"-} SSem.signal (ncHandlingIncomingMessage partner) return True _ -> do -- Nothing to do here, we no longer own the partner MVar.putMVar (ncConnectionState partner) connectionState SSem.signal (ncHandlingIncomingMessage partner) + -- setReadyForUse nc True + -- Config.traceNetIO $ "Set: " ++ ncOwnUserID nc ++ " ready for use" sendSuccess <- NO.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) $ -2 if sendSuccess then return False else do threadDelay 100000 - putStrLn "Trying to lookup future messages" - futureRecieveFromAllContainsPartner vchansmvar ownNC partnerid + return False + -- putStrLn "Trying to lookup future messages" + -- futureRecieveFromAllContainsPartner vchansmvar ownNC partnerid Nothing -> do -- Their partner isnt registered in this instance + -- setReadyForUse nc True + -- Config.traceNetIO $ "Set: " ++ ncOwnUserID nc ++ " ready for use" sendSuccess <- NO.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) $ -2 if sendSuccess then return False else do threadDelay 100000 - putStrLn "Trying to lookup future messages" - futureRecieveFromAllContainsPartner vchansmvar ownNC partnerid + return False + -- putStrLn "Trying to lookup future messages" + -- futureRecieveFromAllContainsPartner vchansmvar ownNC partnerid -- return False _ -> return True @@ -229,10 +251,27 @@ findFittingClient clientlist desiredType = do threadDelay 10000 -- Sleep for 10 ms to not hammer the CPU findFittingClient clientlist desiredType -replaceVChanSerial :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> Value -> IO Value +insertVChansIntoVChanCons :: VChanConnections -> Bool -> Value -> IO () +insertVChansIntoVChanCons vchansmvar readyForUse = searchVChans (handleSerial vchansmvar readyForUse) () (\_ _ -> ()) + where + handleSerial :: VChanConnections -> Bool -> Value -> IO () + handleSerial vchansmvar readyForUse input = case input of + VChanSerial r w p o c -> do + networkconnection <- createNetworkConnection r w p o c + setReadyForUse networkconnection readyForUse + Config.traceNetIO $ "Set: " ++ ncOwnUserID networkconnection ++ " not ready for use" + ncmap <- MVar.takeMVar vchansmvar + MVar.putMVar vchansmvar $ Map.insert p networkconnection ncmap + used<- MVar.newEmptyMVar + MVar.putMVar used False + return () + _ -> return () + +{- +replaceVChanSerial :: NMC.ActiveConnections -> VChanConnections -> Value -> IO Value replaceVChanSerial activeCons mvar input = modifyVChans (handleSerial activeCons mvar) input where - handleSerial :: NMC.ActiveConnections -> MVar.MVar (Map.Map String (NetworkConnection Value)) -> Value -> IO Value + handleSerial :: NMC.ActiveConnections -> VChanConnections -> Value -> IO Value handleSerial activeCons mvar input = case input of VChanSerial r w p o c -> do networkconnection <- createNetworkConnection r w p o c @@ -242,6 +281,33 @@ replaceVChanSerial activeCons mvar input = modifyVChans (handleSerial activeCons MVar.putMVar used False return $ VChan networkconnection used _ -> return input +-} + +replaceVChanSerial :: NMC.ActiveConnections -> VChanConnections -> Value -> IO Value +replaceVChanSerial activeCons mvar input = modifyVChans (handleSerial activeCons mvar) input + where + handleSerial :: NMC.ActiveConnections -> VChanConnections -> Value -> IO Value + handleSerial activeCons mvar input = case input of + VChanSerial r w p o c -> do + ncmap <- MVar.readMVar mvar + case Map.lookup p ncmap of + Nothing -> do + {-networkconnection <- createNetworkConnection r w p o c + ncmap <- MVar.takeMVar mvar + MVar.putMVar mvar $ Map.insert p networkconnection ncmap + used<- MVar.newMVar False + return $ VChan networkconnection used-} + -- This can lead to the value being overwritten + + -- We simply need to wait for the other thread to finish + threadDelay 1000 + handleSerial activeCons mvar input + Just nc -> do + setReadyForUse nc True + Config.traceNetIO $ "Set: " ++ ncOwnUserID nc ++ " ready for use" + used <- MVar.newMVar False + return $ VChan nc used + _ -> return input recieveValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value recieveValue vchanconsvar activeCons networkconnection ownport = do @@ -276,7 +342,7 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do msgCount <- NB.getNextOffset $ ncRead networkconnection connectionState <- MVar.readMVar $ ncConnectionState networkconnection case connectionState of - Connected {} -> NO.sendNetworkMessage activeCons networkconnection (Messages.RequestValue (ncOwnUserID networkconnection) msgCount) 0 + Connected {} -> NO.sendNetworkMessage activeCons networkconnection (Messages.RequestValue (ncOwnUserID networkconnection) msgCount) $ -2 _ -> return True recieveValueInternal 100 vchanconsvar activeCons networkconnection ownport else do diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index e0039a8..e4fd163 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -6,7 +6,7 @@ import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.SSem as SSem import qualified Data.Map as Map -data NetworkConnection a = NetworkConnection {ncRead :: NetworkBuffer a, ncWrite :: NetworkBuffer a, ncPartnerUserID :: String, ncOwnUserID :: String, ncConnectionState :: MVar.MVar ConnectionState, ncHandlingIncomingMessage :: SSem.SSem} +data NetworkConnection a = NetworkConnection {ncRead :: NetworkBuffer a, ncWrite :: NetworkBuffer a, ncPartnerUserID :: String, ncOwnUserID :: String, ncConnectionState :: MVar.MVar ConnectionState, ncHandlingIncomingMessage :: SSem.SSem, ncReadyToBeUsed :: MVar.MVar Bool} deriving Eq data ConnectionState = Connected {csHostname :: String, csPort :: String, csPartnerConnectionID :: String, csOwnConnectionID :: String, csConfirmedConnection :: Bool} @@ -22,7 +22,8 @@ newNetworkConnection partnerID ownID hostname port partnerConnectionID ownConnec write <- newNetworkBuffer connectionstate <- MVar.newMVar $ Connected hostname port partnerConnectionID ownConnectionID True incomingMsg <- SSem.new 1 - return $ NetworkConnection read write partnerID ownID connectionstate incomingMsg + readyForUse <- MVar.newMVar True + return $ NetworkConnection read write partnerID ownID connectionstate incomingMsg readyForUse createNetworkConnection :: ([a], Int, Int) -> ([a], Int, Int) -> String -> String -> (String, String, String) -> IO (NetworkConnection a) @@ -35,8 +36,18 @@ createNetworkConnection (readList, readOffset, readLength) (writeList, writeOffs else MVar.newMVar $ Connected hostname port partnerConnectionID ownConnectionID False incomingMsg <- SSem.new 1 - return $ NetworkConnection read write partnerID ownID connectionstate incomingMsg + readyForUse <- MVar.newMVar True + return $ NetworkConnection read write partnerID ownID connectionstate incomingMsg readyForUse +setReadyForUse :: NetworkConnection a -> Bool -> IO () +setReadyForUse nc ready = do + old <- MVar.takeMVar (ncReadyToBeUsed nc) + MVar.putMVar (ncReadyToBeUsed nc) ready + -- putStrLn $ "setReadyForUse for: " ++ ncOwnUserID nc ++ " was: " ++ show old ++ " now is: " ++ show ready + + +isReadyForUse :: NetworkConnection a -> IO Bool +isReadyForUse nc = MVar.readMVar $ ncReadyToBeUsed nc newEmulatedConnection :: MVar.MVar (Map.Map String (NetworkConnection a)) -> IO (NetworkConnection a, NetworkConnection a) newEmulatedConnection mvar = do @@ -53,8 +64,10 @@ newEmulatedConnection mvar = do userid2 <- newRandomID incomingMsg <- SSem.new 1 incomingMsg2 <- SSem.new 1 - let nc1 = NetworkConnection read write userid2 userid connectionstate incomingMsg - let nc2 = NetworkConnection read2 write2 userid userid2 connectionstate2 incomingMsg2 + readyForUse1 <- MVar.newMVar True + readyForUse2 <- MVar.newMVar True + let nc1 = NetworkConnection read write userid2 userid connectionstate incomingMsg readyForUse1 + let nc2 = NetworkConnection read2 write2 userid userid2 connectionstate2 incomingMsg2 readyForUse2 let ncmap1 = Map.insert userid2 nc1 ncmap let ncmap2 = Map.insert userid nc2 ncmap1 MVar.putMVar mvar ncmap2 diff --git a/src/Networking/Outgoing.hs b/src/Networking/Outgoing.hs index 0c7fbb8..5b8636c 100644 --- a/src/Networking/Outgoing.hs +++ b/src/Networking/Outgoing.hs @@ -132,7 +132,7 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen Nothing -> do sendingNetLog serializedMessage "Error when recieving response" - if resendOnError /= 0 && resendOnError <= (-2) then do + if resendOnError /= 0 && resendOnError < (-2) then do connectionState <- MVar.readMVar $ ncConnectionState networkconnection case connectionState of Connected updatedhost updatedport _ _ _ -> do From 95244fbd9eff6ae04da3697ee3b241f6ba5f3d94 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 7 Mar 2023 18:01:38 +0100 Subject: [PATCH 190/229] Switched to Fedora 37 for my testing container --- README-networking.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README-networking.md b/README-networking.md index 0b6e700..b9f4680 100644 --- a/README-networking.md +++ b/README-networking.md @@ -1,6 +1,6 @@ # How to try LDGVNW for yourself -Using LDGVNW is a little more difficult than simply starting a single program. In addition to the requirements of LDGV you also need a network connected via IPv4, should this network span more than one device the IP-addresses within the LDGVNW programs need to be altered in addition to that. The current version of LDGVNW was tested on Fedora 36 and MacOS 13.2 and should work on every recent Linux or MacOS machine, it is unknown whether LDGVNW works on Windows machines. +Using LDGVNW is a little more difficult than simply starting a single program. In addition to the requirements of LDGV you also need a network connected via IPv4, should this network span more than one device the IP-addresses within the LDGVNW programs need to be altered in addition to that. The current version of LDGVNW was tested on Fedora 37 and MacOS 13.2 and should work on every recent Linux or MacOS machine, it is unknown whether LDGVNW works on Windows machines. To run a LDGVNW example, found in the networking-examples folder, each program in the example folder need to be run at once. So if you would like to start the "handoff" example you would run following commands in different terminals or on different machines: From 3058f68092ab8ce7d20e2745f491b6f7b010471f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 7 Mar 2023 19:12:17 +0100 Subject: [PATCH 191/229] Update Incoming.hs --- src/Networking/Incoming.hs | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/src/Networking/Incoming.hs b/src/Networking/Incoming.hs index 28a4b6a..26083c4 100644 --- a/src/Networking/Incoming.hs +++ b/src/Networking/Incoming.hs @@ -323,6 +323,7 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do waitUntilContactedNewPeers vchanconsvar activeCons networkconnection val ownport -- msgCount <- DC.unreadMessageStart $ ncRead networkconnection connectionState <- MVar.readMVar $ ncConnectionState networkconnection + {- case connectionState of Connected {} -> NO.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (ncOwnUserID networkconnection) $ snd unclean) $ -1 Emulated {} -> do @@ -336,6 +337,8 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do return True _ -> Config.traceNetIO "Something went wrong when acknowleding value of emulated connection" >> return True _ -> return True + -} + waitTillAcknowledged vchanconsvar activeCons networkconnection $ snd unclean return val Nothing -> if count == 0 then do @@ -349,6 +352,32 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do threadDelay 5000 recieveValueInternal (count-1) vchanconsvar activeCons networkconnection ownport +waitTillAcknowledged :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> Int -> IO () +waitTillAcknowledged vcv ac nc vaToAck = do + success <- tryToAcknowledgeValue vcv ac nc vaToAck + unless success $ waitTillAcknowledged vcv ac nc vaToAck + +-- We need to seperate this in case the state of the connection changes to emulated +tryToAcknowledgeValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> Int -> IO Bool +tryToAcknowledgeValue vchanconsvar activeCons networkconnection valueToAcknowledge = do + connectionState <- MVar.readMVar $ ncConnectionState networkconnection + case connectionState of + Connected {} -> NO.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (ncOwnUserID networkconnection) valueToAcknowledge) $ -2 + Emulated {} -> do + vchancons <- MVar.readMVar vchanconsvar + let ownid = ncOwnUserID networkconnection + let mbypartner = Map.lookup ownid vchancons + case mbypartner of + Just partner -> do + -- NB.serialize (ncWrite partner) >>= \x -> Config.traceNetIO $ "Emulated "++ show unclean ++ " before acknowlegment: " ++ show x + NB.updateAcknowledgements (ncWrite partner) valueToAcknowledge + return True + _ -> Config.traceNetIO "Something went wrong when acknowleding value of emulated connection" >> return False + _ -> return True + + + + valueContainsPartner :: String -> Value -> IO Bool valueContainsPartner partner = searchVChans (handleSerial partner) False (||) where From 5c64decfde53f9a57ae557d8cff7e0d33a5716ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 8 Mar 2023 12:18:10 +0100 Subject: [PATCH 192/229] Fixed trying to connect spam when waiting for a connection --- src/Networking/Incoming.hs | 65 ++------------------ src/Networking/NetworkingMethod/Fast.hs | 22 ++++--- src/Networking/NetworkingMethod/Stateless.hs | 22 ++++--- 3 files changed, 34 insertions(+), 75 deletions(-) diff --git a/src/Networking/Incoming.hs b/src/Networking/Incoming.hs index 26083c4..6e27c8a 100644 --- a/src/Networking/Incoming.hs +++ b/src/Networking/Incoming.hs @@ -323,21 +323,6 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do waitUntilContactedNewPeers vchanconsvar activeCons networkconnection val ownport -- msgCount <- DC.unreadMessageStart $ ncRead networkconnection connectionState <- MVar.readMVar $ ncConnectionState networkconnection - {- - case connectionState of - Connected {} -> NO.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (ncOwnUserID networkconnection) $ snd unclean) $ -1 - Emulated {} -> do - vchancons <- MVar.readMVar vchanconsvar - let ownid = ncOwnUserID networkconnection - let mbypartner = Map.lookup ownid vchancons - case mbypartner of - Just partner -> do - -- NB.serialize (ncWrite partner) >>= \x -> Config.traceNetIO $ "Emulated "++ show unclean ++ " before acknowlegment: " ++ show x - NB.updateAcknowledgements (ncWrite partner) $ snd unclean - return True - _ -> Config.traceNetIO "Something went wrong when acknowleding value of emulated connection" >> return True - _ -> return True - -} waitTillAcknowledged vchanconsvar activeCons networkconnection $ snd unclean return val @@ -362,7 +347,10 @@ tryToAcknowledgeValue :: VChanConnections -> NMC.ActiveConnections -> NetworkCon tryToAcknowledgeValue vchanconsvar activeCons networkconnection valueToAcknowledge = do connectionState <- MVar.readMVar $ ncConnectionState networkconnection case connectionState of - Connected {} -> NO.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (ncOwnUserID networkconnection) valueToAcknowledge) $ -2 + Connected {} -> do + success <- NO.sendNetworkMessage activeCons networkconnection (Messages.AcknowledgeValue (ncOwnUserID networkconnection) valueToAcknowledge) $ -2 + unless success $ threadDelay 100000 -- If sending is not successful give the other party some time to recover + return success Emulated {} -> do vchancons <- MVar.readMVar vchanconsvar let ownid = ncOwnUserID networkconnection @@ -373,47 +361,4 @@ tryToAcknowledgeValue vchanconsvar activeCons networkconnection valueToAcknowled NB.updateAcknowledgements (ncWrite partner) valueToAcknowledge return True _ -> Config.traceNetIO "Something went wrong when acknowleding value of emulated connection" >> return False - _ -> return True - - - - -valueContainsPartner :: String -> Value -> IO Bool -valueContainsPartner partner = searchVChans (handleSerial partner) False (||) - where - handleSerial :: String -> Value -> IO Bool - handleSerial partner value = case value of - VChanSerial r w p o c -> do - putStrLn $ "Looking for: " ++ partner ++ " p: " ++ p ++ " o: " ++ o - return (partner == o) - _ -> return False - -futureRecieveFromAllContainsPartner :: VChanConnections -> NetworkConnection Value -> String -> IO Bool -futureRecieveFromAllContainsPartner vchansvar nc partner = do - own <- futureRecieveContainsPartner nc partner - if own then return True else do - consmap <- MVar.readMVar vchansvar - let cons = Map.elems consmap - fRFACPInternal cons partner - where - fRFACPInternal :: [NetworkConnection Value] -> String -> IO Bool - fRFACPInternal [] partner = return False - fRFACPInternal (x:xs) partner = do - containsPartner <- futureRecieveContainsPartner x partner - if containsPartner then return True else fRFACPInternal xs partner - - -futureRecieveContainsPartner :: NetworkConnection Value -> String -> IO Bool -futureRecieveContainsPartner = fRCPInternal 0 - where - fRCPInternal count nc partner = do - putStrLn $ "Trying to read at: " ++ show count - mbyVal <- NB.tryGetAtRelativeNB (ncRead nc) count - case mbyVal of - Nothing -> do - putStrLn $ "Index " ++ show count ++ " is empty" - return False - Just value -> do - putStrLn $ "Looking up index " ++ show count - containsPartner <- valueContainsPartner partner value - if containsPartner then return True else fRCPInternal (count+1) nc partner + _ -> return True \ No newline at end of file diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index 8ed2f32..28911bb 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -94,7 +94,10 @@ recieveNewMessage connection@(handle, isClosed, chan, mvar, sem) = do return (Conversation cid handle mvar sem, serial, deserial) startConversation :: ActiveConnectionsFast -> String -> String -> Int -> Int -> IO (Maybe Conversation) -startConversation acmvar hostname port waitTime tries = do +startConversation = startConversationInternal True + +startConversationInternal :: Bool -> ActiveConnectionsFast -> String -> String -> Int -> Int -> IO (Maybe Conversation) +startConversationInternal shouldShowDebug acmvar hostname port waitTime tries = do conversationid <- newRandomID connectionMap <- MVar.takeMVar acmvar case Map.lookup (hostname, port) connectionMap of @@ -102,7 +105,7 @@ startConversation acmvar hostname port waitTime tries = do handleClosed <- MVar.readMVar isClosed if handleClosed then do statelessActiveCons <- Stateless.createActiveConnections - mbyNewHandle <- Stateless.startConversation statelessActiveCons hostname port waitTime tries + mbyNewHandle <- Stateless.startConversationInternal shouldShowDebug statelessActiveCons hostname port waitTime tries case mbyNewHandle of Just handle -> do newconnection@(handle, isClosed, chan, mvar, sem) <- conversationHandlerChangeHandle handle chan mvar sem @@ -116,7 +119,7 @@ startConversation acmvar hostname port waitTime tries = do return $ Just (Conversation conversationid handle mvar sem) Nothing -> do statelessActiveCons <- Stateless.createActiveConnections - mbyNewHandle <- Stateless.startConversation statelessActiveCons hostname port waitTime tries + mbyNewHandle <- Stateless.startConversationInternal shouldShowDebug statelessActiveCons hostname port waitTime tries case mbyNewHandle of Just handle -> do newconnection@(handle, isClosed, chan, mvar, sem) <- conversationHandler handle @@ -128,10 +131,15 @@ startConversation acmvar hostname port waitTime tries = do waitForConversation :: ActiveConnectionsFast -> String -> String -> Int -> Int -> IO (Maybe Conversation) waitForConversation ac hostname port waitTime tries = do - mbyHandle <- startConversation ac hostname port waitTime tries - case mbyHandle of - Just handle -> return mbyHandle - Nothing -> waitForConversation ac hostname port waitTime tries + Config.traceNetIO $ "Trying to connect to: " ++ hostname ++":"++port + wFCInternal ac hostname port waitTime tries + where + wFCInternal :: ActiveConnectionsFast -> String -> String -> Int -> Int -> IO (Maybe Conversation) + wFCInternal ac hostname port waitTime tries = do + mbyConv <- startConversationInternal False ac hostname port waitTime tries + case mbyConv of + Just conv -> return mbyConv + Nothing -> wFCInternal ac hostname port waitTime tries createActiveConnections :: IO ActiveConnectionsFast createActiveConnections = do diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index 73d7547..56ef83c 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -53,9 +53,8 @@ waitWhileEOF conv@(handle, _) = do onException :: IOException -> IO Bool onException _ = return True - -startConversation :: ActiveConnectionsStateless -> String -> String -> Int -> Int -> IO (Maybe Conversation) -startConversation _ hostname port waitTime tries = do +startConversationInternal :: Bool -> ActiveConnectionsStateless -> String -> String -> Int -> Int -> IO (Maybe Conversation) +startConversationInternal shouldShowDebug _ hostname port waitTime tries = do let hints = defaultHints { addrFamily = AF_INET , addrFlags = [] @@ -63,7 +62,7 @@ startConversation _ hostname port waitTime tries = do } convMVar <- MVar.newEmptyMVar threadid <- forkIO $ catch (do - Config.traceNetIO $ "Trying to connect to: " ++ hostname ++":"++port + when shouldShowDebug $ Config.traceNetIO $ "Trying to connect to: " ++ hostname ++":"++port addrInfo <- getAddrInfo (Just hints) (Just hostname) $ Just port clientsocket <- openSocketNC $ head addrInfo connect clientsocket $ addrAddress $ head addrInfo @@ -73,16 +72,23 @@ startConversation _ hostname port waitTime tries = do ) $ printConErr hostname port getFromNetworkThread Nothing threadid convMVar waitTime tries +startConversation :: ActiveConnectionsStateless -> String -> String -> Int -> Int -> IO (Maybe Conversation) +startConversation = startConversationInternal True printConErr :: String -> String -> IOException -> IO () printConErr hostname port err = Config.traceIO $ "startConversation: Communication Partner " ++ hostname ++ ":" ++ port ++ "not found!" waitForConversation :: ActiveConnectionsStateless -> String -> String -> Int -> Int -> IO (Maybe Conversation) waitForConversation ac hostname port waitTime tries = do - mbyConv <- startConversation ac hostname port waitTime tries - case mbyConv of - Just conv -> return mbyConv - Nothing -> waitForConversation ac hostname port waitTime tries + Config.traceNetIO $ "Trying to connect to: " ++ hostname ++":"++port + wFCInternal ac hostname port waitTime tries + where + wFCInternal :: ActiveConnectionsStateless -> String -> String -> Int -> Int -> IO (Maybe Conversation) + wFCInternal ac hostname port waitTime tries = do + mbyConv <- startConversationInternal False ac hostname port waitTime tries + case mbyConv of + Just conv -> return mbyConv + Nothing -> wFCInternal ac hostname port waitTime tries acceptConversations :: ActiveConnectionsStateless -> ConnectionHandler -> Int -> MVar.MVar (Map.Map Int ServerSocket) -> VChanConnections -> IO ServerSocket From c953039ad0ab6d7276a21116ac5f66d0c1135abd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 8 Mar 2023 13:20:17 +0100 Subject: [PATCH 193/229] Updated readme --- .gitignore | 1 + README-networking-example-communication.md | 119 +++++++++++++++++++++ README-networking.md | 29 ++--- 3 files changed, 136 insertions(+), 13 deletions(-) create mode 100644 README-networking-example-communication.md diff --git a/.gitignore b/.gitignore index d615e00..532a83a 100644 --- a/.gitignore +++ b/.gitignore @@ -27,3 +27,4 @@ stack.yaml.lock result exclude result* +.vscode diff --git a/README-networking-example-communication.md b/README-networking-example-communication.md new file mode 100644 index 0000000..697c955 --- /dev/null +++ b/README-networking-example-communication.md @@ -0,0 +1,119 @@ +# A Communication Example of the Networking in **LDGVNW** + +## The following log shows an exemplary conversation of 4 conversation partners, running the "bidirhandoff" test. + +Explanation: Client connects for the first time to the server +Client(4343)->Server(4242) +Message: NIntroduce (String:"qV8Xo421") (String:"4343") (TName (Bool:False) (String:"SendInt")) (TSend (String:"#!") (TInt) (TRecv (String:"#?") (TInt) (TSend (String:"#!") (TInt) (TRecv (String:"#?") (TInt) (TUnit))))) +Response: NOkayIntroduce (String:"Y1lPJ1sM") + +Explanation: Client sends the first value to the server +Client(4343)->Server(4242) +Message: NNewValue (String:"qV8Xo421") (Int:0) (VInt (Int:1)) +Response: NOkay + +Explanation: Server acknowledges the first value from the client +Server(4242)->Client(4343) +Message: NAcknowledgeValue (String:"Y1lPJ1sM") (Int:0) +Response: NOkay + +Explanation: Server sends the first value to the client +Server(4242)->Client(4343) +Message: NNewValue (String:"Y1lPJ1sM") (Int:0) (VInt (Int:1300)) +Response: NOkay + +Explanation: Client acknowledges the first value from the server +Client(4343)->Server(4242) +Message: NAcknowledgeValue (String:"qV8Xo421") (Int:0) +Response: NOkay + +Explanation: ServerHandoff connects to the Server +ServerHandoff(4240)->Server(4242) +Message: NIntroduce (String:"nCzR17XT") (String:"4240") (TName (Bool:True) (String:"SendSendIntServer")) (TSend (String:"#!") (TName (Bool:False) (String:"SendIntServer")) (TUnit) +Response: NOkayIntroduce(String:"unFbpEeg") + +Explanation: Client connects to the ClientHandoff +Client(4343)->ClientHandoff(4340) +Message: NIntroduce (String:"54AVQX89") (String:"4343") (TName (Bool:False) (String:"SendSendIntClient")) (TSend (String:"#!") (TName (Bool:False) (String:"SendIntClient")) (TUnit)) +Response: NOkayIntroduce (String:"dDF0Te3V") + +Explanation: Server sends the channel to the ServerHandoff, there are no values in the Handoff since all values are already acknowledged +Server(4242)->ServerHandoff(4240) +Message: NNewValue (String:"unFbpEeg") (Int:0) (VChanSerial (((SValuesArray []) (Int:1) (Int:1))) (((SValuesArray []) (Int:1) (Int:1))) (String:"qV8Xo421") (String:"Y1lPJ1sM") (((String:"127.0.0.1") (String:"4343") (String:"qV8Xo421")))) +Response: NOkay + +Explanation: Client sends the channel to the ClientHandoff +Client(4343)->ClientHandoff(4340) +Message: NNewValue (String:"54AVQX89") (Int:0) (VChanSerial (((SValuesArray []) (Int:1) (Int:1))) (((SValuesArray []) (Int:1) (Int:1))) (String:"Y1lPJ1sM") (String:"qV8Xo421") (((String:"127.0.0.1") (String:"4242") (String:"Y1lPJ1sM")))) +Response: NOkay + +Explanation: ClientHandoff wants to introduce itself to the Server, but fails since the channel is now owned by the ServerHandoff +ClientHandoff(4340)->Server(4242) +Message: NNewPartnerAddress (String:"qV8Xo421") (String:"4340") (String:"hh0kAZdY") +Response: NRedirect (String:"127.0.0.1") (String:"4240") + +Explanation: ServerHandoff wants to introduce itself to the Client, but fails since the channel is now owned by the ClientHandoff +ServerHandoff(4240)->Client(4343) +Message: NNewPartnerAddress (String:"Y1lPJ1sM") (String:"4240") (String:"OUN8jvH1") +Response: NRedirect (String:"127.0.0.1") (String:"4240") + +Explanation: ClientHandoff introduces itself to the ServerHandoff +ClientHandoff(4340)->ServerHandoff(4240) +Message: NNewPartnerAddress (String:"qV8Xo421") (String:"4340") (String:"hh0kAZdY") +Response: NOkay + +Explanation: ServerHandoff introduces itself to the ClientHandoff +ServerHandoff(4240)->ClientHandoff(4340) +Message: NNewPartnerAddress (String:"Y1lPJ1sM") (String:"4240") (String:"OUN8jvH1") +Response: NOkay + +Explanation: ClientHandoff acknowledges the new address of the ServerHandoff +ClientHandoff(4340)->ServerHandoff(4240) +Message: NAcknowledgePartnerAddress (String:"qV8Xo421") (String:"OUN8jvH1") +Response: NOkay + +Explanation: ServerHandoff acknowledges the new address of the ClientHandoff +ServerHandoff(4240)->ClientHandoff(4340) +Message: NAcknowledgePartnerAddress (String:"Y1lPJ1sM") (String:"hh0kAZdY") +Response: NOkay + +Explanation: Since the ServerHandoff has acknowledged the new address, the ClientHandoff can now acknowledge the successful receiving of the Channel to the Client +ClientHandoff(4340)->Client(4343) +Message: NAcknowledgeValue (String:"dDF0Te3V") (Int:0) +Response: NOkay + +Explanation: Since the ClientHandoff has acknowledged the new address, the ServerHandoff can now acknowledge the successful receiving of the Channel to the Server +ServerHandoff(4240)->Server(4242) +Message: NAcknowledgeValue (String:"nCzR17XT") (Int:0) +Response: NOkay + + +ClientHandoff(4340)->ServerHandoff(4240) +Message: NNewValue (String:"qV8Xo421") (Int:1) (VInt (Int:41)) +Response: NOkay + +Explanation: Since the client now has all of the values of its active connections acknowledged, it can disconnect +Client(4343)->ClientHandoff(4340) +Message: NDisconnect (String:"54AVQX89") +Response: NOkay + +Explanation: Since the server has now all of the values of its active connections acknowledged, it can disconnect +Server(4242)->ServerHandoff(4240) +Message: NDisconnect (String:"unFbpEeg") +Response: NOkay + +ServerHandoff(4240)->ClientHandoff(4340) +Message: NAcknowledgeValue (String:"Y1lPJ1sM") (Int:1) +Response: NOkay + +ServerHandoff(4240)->ClientHandoff(4340) +Message: NNewValue (String:"Y1lPJ1sM") (Int:1) (VInt (Int:37)) +Response: NOkay + +ClientHandoff(4340)->ServerHandoff(4240) +Message: NAcknowledgeValue (String:"qV8Xo421") (Int:1) +Response: NOkay + +ServerHandoff(4240)->ClientHandoff(4340) +Message: NDisconnect (String:"Y1lPJ1sM") +Response: NOkay \ No newline at end of file diff --git a/README-networking.md b/README-networking.md index b9f4680..b2bc72d 100644 --- a/README-networking.md +++ b/README-networking.md @@ -1,22 +1,22 @@ -# How to try LDGVNW for yourself +# How to try **LDGVNW** for yourself -Using LDGVNW is a little more difficult than simply starting a single program. In addition to the requirements of LDGV you also need a network connected via IPv4, should this network span more than one device the IP-addresses within the LDGVNW programs need to be altered in addition to that. The current version of LDGVNW was tested on Fedora 37 and MacOS 13.2 and should work on every recent Linux or MacOS machine, it is unknown whether LDGVNW works on Windows machines. +Using **LDGVNW** is a little more difficult than simply starting a single program. In addition to the requirements of **LDGV** you also need a network connected via IPv4, should this network span more than one device the IP-addresses within the **LDGVNW** programs need to be altered in addition to that. The current version of **LDGVNW** was tested on Fedora 37 and MacOS 13.2 and should work on every recent Linux or MacOS machine, it is unknown whether **LDGVNW** works on Windows machines. -To run a LDGVNW example, found in the networking-examples folder, each program in the example folder need to be run at once. So if you would like to start the "handoff" example you would run following commands in different terminals or on different machines: +To run a **LDGVNW** example, found in the networking-examples folder, each program in the example folder need to be run at once. So if you would like to start the "handoff" example you would run following commands in different terminals or on different machines: - stack run ldgv -- interpret networking-examples/handoff/client.ldgvnw - stack run ldgv -- interpret networking-examples/handoff/server.ldgvnw -- stack run ldgv -- interpret networking-examples/handoff/handoff.ldgbnw +- stack run ldgv -- interpret networking-examples/handoff/handoff.ldgvnw The order in which these commands are executed does not matter. -To test all the different testcases in a easier way, they can be automatically run, with the scrips provided in the networking-tests folder. Simply running one of these scripts will run the whole testcase at once. +To test all the different test-cases in a easier way, they can be automatically run, with the scrips provided in the networking-tests folder. Simply running one of these scripts will run the whole test-case at once. The testNW* scripts contain all the tests, except for the recursion test. -# An Introduction to LDGVNWs Networking Architecture +# An Introduction to **LDGVNW**s Networking Architecture -LDGVNW adds networking capabilities to LDGV. To enable this, LDGVNW adds 2 new commands: +**LDGVNW** adds networking capabilities to **LDGV**. To enable this, **LDGVNW** adds 2 new commands: - **accept \ \** - **connect \ \ \ \** @@ -28,7 +28,7 @@ Important to note is that, with the current implementation, only IPv4 addresses ## The Logical Communication Architecture ### Messages and Responses -In LDGVNW there are 7 possible **Messages** and 4 possible **Responses**. +In **LDGVNW** there are 7 possible **Messages** and 4 possible **Responses**. The messages are: - **Introduce \ \ \ \** @@ -63,13 +63,13 @@ The **UserID** is a unique identifier, so a message can be associated with the c As soon as **B** opens up their port with the **accept** command. **A** can **connect**, by sending a **Introduce** message to **B**. This message contains the unique ID of **A**, **A**s port as well as the name and structure of the desired communication **Type**. **B** then answers with a **OkayIntroduce** response, sharing their own unique ID with **A**. Following that **A** and **B** can **send** and **recv** values analog to **Channels** created with the **new** command. ### Sending messages over a Connection -When communication partner **A** executes a send instruction to **send** Value **V** to **B**, **A** first analyses **V**. Should **V** be or contain a **Channel** **C**, receiving messages for **C** will be redirected to the address of **B** and the state of **C** will be converted to a serializable form **CS**. After that **V** will be serialized to **VS**, which will be written to **A**s write-buffer and sent to **B** via a **NewValue** message. Upon recieving **VS** as **B** with the **recv** instruction, **VS** will be deserialized to **VD**. Should **VD** contain a serialized form of a **Channel** this **Channel** will be convered to a regular **Channel** **CD** and the communication partner of **CD** will be informed of the communication partner change. After this **B** sends an acknowledgment (**AcknowledgeValue** message) back to **A**, which finalizes the sending of **V**, by **A** removing **V** out of its write-buffer. +When communication partner **A** executes a send instruction to **send** Value **V** to **B**, **A** first analyses **V**. Should **V** be or contain a **Channel** **C**, receiving messages for **C** will be redirected to the address of **B** and the state of **C** will be converted to a serializable form **CS**. After that **V** will be serialized to **VS**, which will be written to **A**s write-buffer and sent to **B** via a **NewValue** message. Upon receiving **VS** as **B** with the **recv** instruction, **VS** will be deserialized to **VD**. Should **VD** contain a serialized form of a **Channel** this **Channel** will be converted to a regular **Channel** **CD** and the communication partner of **CD** will be informed of the communication partner change. After this **B** sends an acknowledgment (**AcknowledgeValue** message) back to **A**, which finalizes the sending of **V**, by **A** removing **V** out of its write-buffer. ### Responding to Messages With the exception of the **Introduce** message, every message should be answered with a **Okay** response. Exceptions to that are **Redirect** responses, which are used when a message is sent to an outdated address or **Wait** responses which are sent when a message cannot be handled at the current moment. This can happen when the communication partner is already handling a message in a critical section, or a communication partner is currently in the progress of sending the **Channel** which the message is sent to. ### Informing communication partners of a communication partner change -If a **Channel** **C** got sent over a network connection to **A**, the new communication partner **B** needs to be notified of this change. To archive this **A** sends a **NewParterAddress** message to **B**. This message contains the server port of **A** and the new ConnectionID **AC** for **A**. **B** then replies with a **AcknowledgeParterAddress** message, repeating **AC**. As soon as the address is established **C** is considered being successfully received by **A**. +If a **Channel** **C** got sent over a network connection to **A**, the new communication partner **B** needs to be notified of this change. To archive this **A** sends a **NewPartnerAddress** message to **B**. This message contains the server port of **A** and the new ConnectionID **AC** for **A**. **B** then replies with a **AcknowledgePartnerAddress** message, repeating **AC**. As soon as the address is established **C** is considered being successfully received by **A**. ### Shutting down after completing all the instructions @@ -77,23 +77,26 @@ After **A** finishes the interpretation of their program, **A** waits until all ### A communication example +In the README-networking-example-communication.md is an example explaining the communication protocol on a concrete example + ## Serializing and Sending Messages The logical messages are serialized first, then are sent either using a fast protocol which reuses existing connections or a stateless protocol, which was primary used during development as a fallback when the fest protocol wasn't working, yet. ### Serialization -Messages and Responses in LDGVNW are serialized into ASCII-Strings and follow usually the form of the name of the Message, Value, etc. followed by their arguments in brackets. For instance the message **NewValue \ \<2> \** would be translated to **NNewValue (String:"abcd1234") (Int:2) (VInt (Int:42))** +Messages and Responses in **LDGVNW** are serialized into ASCII-Strings and follow usually the form of the name of the Message, Value, etc. followed by their arguments in brackets. For instance the message **NewValue \ \<2> \** would be translated to **NNewValue (String:"abcd1234") (Int:2) (VInt (Int:42))** ### Stateless Protocol The stateless protocol allows to directly send serialized logical messages, by establishing a new connection, sending the serialized message, waiting for a response and disconnecting afterward. By always creating new connections it can be assured that every Message gets their correct response, but establishing a new TCP connection every time a message is sent also causes a huge performance penalty. ### Fast Protocol -The fast protocol saves a once created TCP connection and reuses it as long as it stays open. Since LDGVNW uses multiple threads to send Messages this can lead to Messages and Responses to be mismatched. To avoid this each Message and Response is wrapped in a ConversationSession. +The fast protocol saves a once created TCP connection and reuses it as long as it stays open. Since **LDGVNW** uses multiple threads to send Messages this can lead to Messages and Responses to be mismatched. To avoid this each Message and Response is wrapped in a ConversationSession. - **ConversationMessage \ \** - **ConversationResponse \ \** - **ConversationCloseAll** -The ConversationID is a random string, selected by the sender of the message and copied by the respondent. **ConversationCloseAll**} is used when one party wants to close all connections to a peer, signaling to their peer that they would need to establish a new connection if they would like to talk to this port again. +The ConversationID is a random string, selected by the sender of the message and copied by the respondent. **ConversationCloseAll** is used when one party wants to close all connections to a peer, signaling to their peer that they would need to establish a new connection if they would like to talk to this port again. ## Compatibility between Internal and External Channels +Internal channels (channels in the same program, created with **new**) and external channels (channels between two programs, created with **connect** and **accept**) are handled for the most part the same way in **LDGVNW**. Every channel has a **NetworkConnection** object, which saves both incoming and outgoing messages, it also has a **ConnectionState** object, which dictates whether a **NetworkConnection** is internal or external. Should a internal connection be send to a peer, both the internal connection gets converted into an external connection. Should both sides of a external connection end up in the same program, the connection will be converted to an internal connection. From c431be8266a354b83db1e9ee747c8465a5613536 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 8 Mar 2023 13:26:22 +0100 Subject: [PATCH 194/229] Fixed naming --- ...mmunication.md => README-networking-communication-example.md | 0 README-networking.md | 2 +- 2 files changed, 1 insertion(+), 1 deletion(-) rename README-networking-example-communication.md => README-networking-communication-example.md (100%) diff --git a/README-networking-example-communication.md b/README-networking-communication-example.md similarity index 100% rename from README-networking-example-communication.md rename to README-networking-communication-example.md diff --git a/README-networking.md b/README-networking.md index b2bc72d..add382e 100644 --- a/README-networking.md +++ b/README-networking.md @@ -77,7 +77,7 @@ After **A** finishes the interpretation of their program, **A** waits until all ### A communication example -In the README-networking-example-communication.md is an example explaining the communication protocol on a concrete example +In the README-networking-communication-example.md is an example explaining the communication protocol on a concrete example ## Serializing and Sending Messages The logical messages are serialized first, then are sent either using a fast protocol which reuses existing connections or a stateless protocol, which was primary used during development as a fallback when the fest protocol wasn't working, yet. From 7d60b4729a3ba389df795897add01757d277dded Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 8 Mar 2023 14:33:04 +0100 Subject: [PATCH 195/229] Update README-networking.md --- README-networking.md | 66 ++++++++++++++++++++++++++++---------------- 1 file changed, 42 insertions(+), 24 deletions(-) diff --git a/README-networking.md b/README-networking.md index add382e..052a3db 100644 --- a/README-networking.md +++ b/README-networking.md @@ -1,8 +1,8 @@ -# How to try **LDGVNW** for yourself +# How to run **LDGVNW** -Using **LDGVNW** is a little more difficult than simply starting a single program. In addition to the requirements of **LDGV** you also need a network connected via IPv4, should this network span more than one device the IP-addresses within the **LDGVNW** programs need to be altered in addition to that. The current version of **LDGVNW** was tested on Fedora 37 and MacOS 13.2 and should work on every recent Linux or MacOS machine, it is unknown whether **LDGVNW** works on Windows machines. +Using **LDGVNW** is a little more difficult than simply starting a single program. In addition to the requirements of **LDGV** you also need a network connected via IPv4. Should this network span more than one device, the IP-addresses within the **LDGVNW** programs need to be altered to reflect this architecture. The current version of **LDGVNW** was tested on Fedora 37 and MacOS 13.2 and should work on every recent Linux or MacOS machine, it is unknown whether **LDGVNW** works on Windows machines. -To run a **LDGVNW** example, found in the networking-examples folder, each program in the example folder need to be run at once. So if you would like to start the "handoff" example you would run following commands in different terminals or on different machines: +To run a **LDGVNW** example program, found in the networking-examples folder, each program in the example folder need to be run. So to start the "handoff" example you would run following commands in different terminals or on different machines: - stack run ldgv -- interpret networking-examples/handoff/client.ldgvnw - stack run ldgv -- interpret networking-examples/handoff/server.ldgvnw @@ -11,7 +11,7 @@ To run a **LDGVNW** example, found in the networking-examples folder, each progr The order in which these commands are executed does not matter. To test all the different test-cases in a easier way, they can be automatically run, with the scrips provided in the networking-tests folder. Simply running one of these scripts will run the whole test-case at once. -The testNW* scripts contain all the tests, except for the recursion test. +The testNW\* scripts contain all the tests, except for the recursion test. # An Introduction to **LDGVNW**s Networking Architecture @@ -21,9 +21,12 @@ The testNW* scripts contain all the tests, except for the recursion test. - **accept \ \** - **connect \ \ \ \** -The **accept** command requires an integer as a port for others to connect, and a type that will be required of a connecting connection. Once a communication partner connects with a desired type, the **accept** command will return a **VChan**. -The **connect** command also requires an integer port and a desired type, but also needs to specify a string for the address of the connection partner as well as an integer for the port of the connection partner. Just like with the **accept** command, the **connect** command will return a **VChan** once a connection has been established. -Important to note is that, with the current implementation, only IPv4 addresses are supported. IPv6 and Unix domain sockets could be supported in the future with a relatively low effort. +The **accept** command requires an integer as a port for others to connect and a type that will be required of a connecting connection. +Once a communication partner connects with a desired type, the **accept** command will return a **VChan**. +The **connect** command also requires an integer port and a desired type, but also needs to specify a string for the address of the connection partner as well as an integer for the port of the connection partner. +Just like with the **accept** command, the **connect** command will return a **VChan** once a connection has been established. +Important to note is that, with the current implementation, only IPv4 addresses are supported. +IPv6 and Unix domain sockets could be supported in the future with a relatively low effort. ## The Logical Communication Architecture @@ -49,54 +52,69 @@ With possible responses: Typing for the attributes: - **UserID** A unique string, used to identify the logical communication partner -- **ConnectionID** A unique string, used to identify the physical communication partner +- **ConnectionID** A unique string, used to identify the current physical connection to the logical communication partner - **Port** A string containing the number of a port - **Address** A string containing the IPv4 or URL of a communication partner -- **Value** The serialization of the sent Value -- **Value Index** A integer containing the index of a Value -- **Type Name** The serialization of the TName Type of the desired Type -- **Type Structure** The serialization of the type structure of the desired Type - -The **UserID** is a unique identifier, so a message can be associated with the correct communication partner. +- **Value** The **Value** which should be sent, with the **VChans** replaced with **VChanSerials** +- **Value Index** A integer containing the index of a **Value** +- **Type Name** The **TName Type** of the desired **Type** +- **Type Structure** The type structure of the desired **Type** ### Establishing a new Connection -As soon as **B** opens up their port with the **accept** command. **A** can **connect**, by sending a **Introduce** message to **B**. This message contains the unique ID of **A**, **A**s port as well as the name and structure of the desired communication **Type**. **B** then answers with a **OkayIntroduce** response, sharing their own unique ID with **A**. Following that **A** and **B** can **send** and **recv** values analog to **Channels** created with the **new** command. +As soon as **B** opens up their port with the **accept** command. **A** can **connect**, by sending a **Introduce** message to **B**. +This message contains the unique ID of **A**, **A**s port as well as the name and structure of the desired communication **Type**. +**B** then answers with a **OkayIntroduce** response, sharing their own unique ID with **A**. +Following that **A** and **B** can **send** and **recv** values analog to **Channels** created with the **new** command. ### Sending messages over a Connection -When communication partner **A** executes a send instruction to **send** Value **V** to **B**, **A** first analyses **V**. Should **V** be or contain a **Channel** **C**, receiving messages for **C** will be redirected to the address of **B** and the state of **C** will be converted to a serializable form **CS**. After that **V** will be serialized to **VS**, which will be written to **A**s write-buffer and sent to **B** via a **NewValue** message. Upon receiving **VS** as **B** with the **recv** instruction, **VS** will be deserialized to **VD**. Should **VD** contain a serialized form of a **Channel** this **Channel** will be converted to a regular **Channel** **CD** and the communication partner of **CD** will be informed of the communication partner change. After this **B** sends an acknowledgment (**AcknowledgeValue** message) back to **A**, which finalizes the sending of **V**, by **A** removing **V** out of its write-buffer. +When communication partner **A** executes a send instruction to **send** Value **V** to **B**, **A** first analyses **V**. +Should **V** be or contain a Channel **C**, **A** will set a flag for in **C** to redirect new messages to the address of **B**. +After that **C** will be converted to a serializable form **CS**. +With every channel now being in a form which can be send over the network, **A** now writes **V** to its write-buffer ands sends **B** a **NewValue** message containing **V**. +Upon receiving **V** as **B** with the **recv** instruction, **B** now undoes the conversion of every Channel in **V** from **CS** to **C**. +And contacts the communication partner of each Channel, to inform them that their new communication partner is now **B** instead of **A**. +After this **B** sends an acknowledgment (**AcknowledgeValue** message) back to **A**, which finalizes the sending of **V**. +**A** can now remove **V** out of its write-buffer. ### Responding to Messages -With the exception of the **Introduce** message, every message should be answered with a **Okay** response. Exceptions to that are **Redirect** responses, which are used when a message is sent to an outdated address or **Wait** responses which are sent when a message cannot be handled at the current moment. This can happen when the communication partner is already handling a message in a critical section, or a communication partner is currently in the progress of sending the **Channel** which the message is sent to. +With the exception of the **Introduce** message, every message should be answered with a **Okay** response. +Exceptions to that are **Redirect** responses, which are used when a message is sent to an outdated address or **Wait** responses which are sent when a message cannot be handled at the current moment. +This can happen when the communication partner is already handling a message in a critical section, or a communication partner is currently in the progress of sending the Channel which the message is sent to. ### Informing communication partners of a communication partner change -If a **Channel** **C** got sent over a network connection to **A**, the new communication partner **B** needs to be notified of this change. To archive this **A** sends a **NewPartnerAddress** message to **B**. This message contains the server port of **A** and the new ConnectionID **AC** for **A**. **B** then replies with a **AcknowledgePartnerAddress** message, repeating **AC**. As soon as the address is established **C** is considered being successfully received by **A**. - +If there is a Channel **C** between **A** and **B** and **A** sends their side of the Channel to **D**, **B** needs to be made aware of that. +To archive this **D** sends a **NewPartnerAddress** message to **B**. This message contains the server port of **D** and a new ConnectionID **DC** for **D**. +**B** then replies with a **AcknowledgePartnerAddress** message, repeating **DC**. +As soon as the address is established, **C** is considered successfully received by **D**. ### Shutting down after completing all the instructions -After **A** finishes the interpretation of their program, **A** waits until all messages it sent were acknowledged by their communication partners. After that **A** sends a **Disconnect** message to all its peers. The **Disconnect** message is needed to avoid rewriting a large portion of the interpreter to annotate each expression with their associated output **Types**. Should the **Disconnect** message not exist, it would be theoretically possible to send a **Unit=Type** of an exhausted **Channel** to another communication partner. The recipient would now be unknowing whether their new communication partner were still online. +After **A** finishes the interpretation of their program, **A** waits until all messages it sent were acknowledged by their communication partners. After that **A** sends a **Disconnect** message to all its peers. The **Disconnect** message is needed to avoid rewriting a large portion of the interpreter to annotate each expression with their associated output **Types**. Should the **Disconnect** message not exist, it would be theoretically possible to send a **Unit-Type** of an exhausted **Channel** to another communication partner. The recipient would now be unknowing whether their new communication partner were still online. ### A communication example In the README-networking-communication-example.md is an example explaining the communication protocol on a concrete example ## Serializing and Sending Messages -The logical messages are serialized first, then are sent either using a fast protocol which reuses existing connections or a stateless protocol, which was primary used during development as a fallback when the fest protocol wasn't working, yet. +The logical messages are serialized first, then are sent either using a fast protocol which reuses existing connections or a stateless protocol, which was primary used during development as a fallback when the fast protocol wasn't working yet. ### Serialization Messages and Responses in **LDGVNW** are serialized into ASCII-Strings and follow usually the form of the name of the Message, Value, etc. followed by their arguments in brackets. For instance the message **NewValue \ \<2> \** would be translated to **NNewValue (String:"abcd1234") (Int:2) (VInt (Int:42))** +To deserialize these messages the alex and happy libraries are used. + ### Stateless Protocol -The stateless protocol allows to directly send serialized logical messages, by establishing a new connection, sending the serialized message, waiting for a response and disconnecting afterward. By always creating new connections it can be assured that every Message gets their correct response, but establishing a new TCP connection every time a message is sent also causes a huge performance penalty. +The stateless protocol allows to directly send serialized logical messages, by establishing a new connection, sending the serialized message, waiting for a response and disconnecting afterward. By always creating new connections it can be assured that every Message gets their correct response, but establishing a new TCP connection every time a message is sent also causes a huge performance penalty. The stateless protocol creates a new temporary thread to handle each incoming message. Messages are mainly send from the main thread, in which also the interpretation occurs, with the exception of some messages like the acknowledging of a new partner address, which is sent from the temporary thread. ### Fast Protocol -The fast protocol saves a once created TCP connection and reuses it as long as it stays open. Since **LDGVNW** uses multiple threads to send Messages this can lead to Messages and Responses to be mismatched. To avoid this each Message and Response is wrapped in a ConversationSession. +The fast protocol saves a once created TCP connection and reuses it as long as it stays open. Since **LDGVNW** uses multiple threads to send Messages this can lead to Messages and Responses to be mismatched. To avoid this, each Message and Response is wrapped in a ConversationSession. - **ConversationMessage \ \** - **ConversationResponse \ \** - **ConversationCloseAll** The ConversationID is a random string, selected by the sender of the message and copied by the respondent. **ConversationCloseAll** is used when one party wants to close all connections to a peer, signaling to their peer that they would need to establish a new connection if they would like to talk to this port again. +Similar to the stateless protocol most messages are sent from the main thread, but since the TCP connections are saved and reused, the threads handling all messages from a given conversation partner are also reused. ## Compatibility between Internal and External Channels -Internal channels (channels in the same program, created with **new**) and external channels (channels between two programs, created with **connect** and **accept**) are handled for the most part the same way in **LDGVNW**. Every channel has a **NetworkConnection** object, which saves both incoming and outgoing messages, it also has a **ConnectionState** object, which dictates whether a **NetworkConnection** is internal or external. Should a internal connection be send to a peer, both the internal connection gets converted into an external connection. Should both sides of a external connection end up in the same program, the connection will be converted to an internal connection. +Internal channels (channels in the same program, created with **new**) and external channels (channels between two programs, created with **connect** and **accept**) are handled for the most part the same way in **LDGVNW**. Every channel has a **NetworkConnection** object, which saves both incoming and outgoing messages, it also has a **ConnectionState** object, which dictates whether a **NetworkConnection** is internal or external. Should a internal connection be send to a peer, the internal connection gets converted into an external connection. Should both sides of a external connection end up in the same program, the connection will be converted to an internal connection. From 3acb1dfeeecc860b7beb7ef8cca1e75a8cce3290 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 8 Mar 2023 17:04:59 +0100 Subject: [PATCH 196/229] Updated readmes --- README-networking-communication-example.md | 8 +-- README-networking.md | 60 +++++++++++----------- 2 files changed, 36 insertions(+), 32 deletions(-) diff --git a/README-networking-communication-example.md b/README-networking-communication-example.md index 697c955..0beaab2 100644 --- a/README-networking-communication-example.md +++ b/README-networking-communication-example.md @@ -1,7 +1,8 @@ -# A Communication Example of the Networking in **LDGVNW** +# A Communication Example of Networking in **LDGVNW** -## The following log shows an exemplary conversation of 4 conversation partners, running the "bidirhandoff" test. +The following log shows an conversation of 4 conversation partners, running the "bidirhandoff" test. +``` Explanation: Client connects for the first time to the server Client(4343)->Server(4242) Message: NIntroduce (String:"qV8Xo421") (String:"4343") (TName (Bool:False) (String:"SendInt")) (TSend (String:"#!") (TInt) (TRecv (String:"#?") (TInt) (TSend (String:"#!") (TInt) (TRecv (String:"#?") (TInt) (TUnit))))) @@ -116,4 +117,5 @@ Response: NOkay ServerHandoff(4240)->ClientHandoff(4340) Message: NDisconnect (String:"Y1lPJ1sM") -Response: NOkay \ No newline at end of file +Response: NOkay +``` \ No newline at end of file diff --git a/README-networking.md b/README-networking.md index 052a3db..2e4f6a4 100644 --- a/README-networking.md +++ b/README-networking.md @@ -1,16 +1,16 @@ # How to run **LDGVNW** -Using **LDGVNW** is a little more difficult than simply starting a single program. In addition to the requirements of **LDGV** you also need a network connected via IPv4. Should this network span more than one device, the IP-addresses within the **LDGVNW** programs need to be altered to reflect this architecture. The current version of **LDGVNW** was tested on Fedora 37 and MacOS 13.2 and should work on every recent Linux or MacOS machine, it is unknown whether **LDGVNW** works on Windows machines. +Using **LDGVNW** is a little more difficult than simply starting a single program. In addition to the requirements of **LDGV**, you also need a network connected via IPv4. Should this network span more than one device, the IP-addresses within the **LDGVNW** programs need to be altered to reflect this architecture. The current version of **LDGVNW** was tested on Fedora 37 and macOS 13.2 and should work on every recent Linux or macOS machine, it is unknown whether **LDGVNW** works on Windows machines. -To run a **LDGVNW** example program, found in the networking-examples folder, each program in the example folder need to be run. So to start the "handoff" example you would run following commands in different terminals or on different machines: +To run a **LDGVNW** example program, found in the networking-examples folder, each program in the example folder needs to be run. To start the "handoff" example, you would run the following commands in different terminals or on different machines: - stack run ldgv -- interpret networking-examples/handoff/client.ldgvnw - stack run ldgv -- interpret networking-examples/handoff/server.ldgvnw - stack run ldgv -- interpret networking-examples/handoff/handoff.ldgvnw -The order in which these commands are executed does not matter. +The order in which these commands are executed is not relevant. -To test all the different test-cases in a easier way, they can be automatically run, with the scrips provided in the networking-tests folder. Simply running one of these scripts will run the whole test-case at once. +To test all the different test-cases in an easier way, they can be automatically run, with the scrips provided in the networking-tests folder. Simply running one of these scripts will run the whole test-case at once. The testNW\* scripts contain all the tests, except for the recursion test. @@ -31,7 +31,7 @@ IPv6 and Unix domain sockets could be supported in the future with a relatively ## The Logical Communication Architecture ### Messages and Responses -In **LDGVNW** there are 7 possible **Messages** and 4 possible **Responses**. +In **LDGVNW**, there are 7 possible **Messages** and 4 possible **Responses**. The messages are: - **Introduce \ \ \ \** @@ -51,44 +51,44 @@ With possible responses: Typing for the attributes: -- **UserID** A unique string, used to identify the logical communication partner -- **ConnectionID** A unique string, used to identify the current physical connection to the logical communication partner -- **Port** A string containing the number of a port -- **Address** A string containing the IPv4 or URL of a communication partner -- **Value** The **Value** which should be sent, with the **VChans** replaced with **VChanSerials** -- **Value Index** A integer containing the index of a **Value** -- **Type Name** The **TName Type** of the desired **Type** -- **Type Structure** The type structure of the desired **Type** +- **UserID** is a unique string, used to identify the logical communication partner +- **ConnectionID** is a unique string, used to identify the current physical connection to the logical communication partner +- **Port** is a string containing the number of a port +- **Address** is a string containing the IPv4 or URL of a communication partner +- **Value**is a data-type in **LDGV**. The **VChans** are replaced with **VChanSerials** +- **Value Index** is an integer containing the index of a **Value** +- **Type Name** is a **TName Type** of the desired **Type** +- **Type Structure** of the desired **Type** ### Establishing a new Connection -As soon as **B** opens up their port with the **accept** command. **A** can **connect**, by sending a **Introduce** message to **B**. -This message contains the unique ID of **A**, **A**s port as well as the name and structure of the desired communication **Type**. +As soon as **B** opens up their port with the **accept** command. **A** can **connect**, by sending an **Introduce** message to **B**. +This message contains the unique ID of **A**, **A**s port, as well as the name and structure of the desired communication **Type**. **B** then answers with a **OkayIntroduce** response, sharing their own unique ID with **A**. -Following that **A** and **B** can **send** and **recv** values analog to **Channels** created with the **new** command. +Following that, **A** and **B** can **send** and **recv** values analog to **Channels** created with the **new** command. ### Sending messages over a Connection When communication partner **A** executes a send instruction to **send** Value **V** to **B**, **A** first analyses **V**. Should **V** be or contain a Channel **C**, **A** will set a flag for in **C** to redirect new messages to the address of **B**. -After that **C** will be converted to a serializable form **CS**. -With every channel now being in a form which can be send over the network, **A** now writes **V** to its write-buffer ands sends **B** a **NewValue** message containing **V**. +After that, **C** will be converted to a serializable form **CS**. +With every channel now being in a form which can be sent over the network, **A** now writes **V** to its write-buffer and sends **B** a **NewValue** message containing **V**. Upon receiving **V** as **B** with the **recv** instruction, **B** now undoes the conversion of every Channel in **V** from **CS** to **C**. And contacts the communication partner of each Channel, to inform them that their new communication partner is now **B** instead of **A**. -After this **B** sends an acknowledgment (**AcknowledgeValue** message) back to **A**, which finalizes the sending of **V**. +After this, **B** sends an acknowledgment (**AcknowledgeValue** message) back to **A**, which finalizes the sending of **V**. **A** can now remove **V** out of its write-buffer. ### Responding to Messages -With the exception of the **Introduce** message, every message should be answered with a **Okay** response. -Exceptions to that are **Redirect** responses, which are used when a message is sent to an outdated address or **Wait** responses which are sent when a message cannot be handled at the current moment. +Except for the **Introduce** message, every message should be answered with an **Okay** response. +Exceptions to that are **Redirect** responses, which are used when a message is sent to an outdated address or **Wait** responses, which are sent when a message cannot be handled at the current moment. This can happen when the communication partner is already handling a message in a critical section, or a communication partner is currently in the progress of sending the Channel which the message is sent to. ### Informing communication partners of a communication partner change If there is a Channel **C** between **A** and **B** and **A** sends their side of the Channel to **D**, **B** needs to be made aware of that. -To archive this **D** sends a **NewPartnerAddress** message to **B**. This message contains the server port of **D** and a new ConnectionID **DC** for **D**. +To archive this, **D** sends a **NewPartnerAddress** message to **B**. This message contains the server port of **D** and a new ConnectionID **DC** for **D**. **B** then replies with a **AcknowledgePartnerAddress** message, repeating **DC**. As soon as the address is established, **C** is considered successfully received by **D**. ### Shutting down after completing all the instructions -After **A** finishes the interpretation of their program, **A** waits until all messages it sent were acknowledged by their communication partners. After that **A** sends a **Disconnect** message to all its peers. The **Disconnect** message is needed to avoid rewriting a large portion of the interpreter to annotate each expression with their associated output **Types**. Should the **Disconnect** message not exist, it would be theoretically possible to send a **Unit-Type** of an exhausted **Channel** to another communication partner. The recipient would now be unknowing whether their new communication partner were still online. +After **A** finishes the interpretation of their program, **A** waits until all messages it sent were acknowledged by their communication partners. After that, **A** sends a **Disconnect** message to all its peers. The **Disconnect** message is needed to avoid rewriting a large portion of the interpreter to annotate each expression with their associated output **Types**. Should the **Disconnect** message not exist, it would be theoretically possible to send a **Unit-Type** of an exhausted **Channel** to another communication partner. The recipient would now be unknowing whether their new communication partner were still online. ### A communication example @@ -98,23 +98,25 @@ In the README-networking-communication-example.md is an example explaining the c The logical messages are serialized first, then are sent either using a fast protocol which reuses existing connections or a stateless protocol, which was primary used during development as a fallback when the fast protocol wasn't working yet. ### Serialization -Messages and Responses in **LDGVNW** are serialized into ASCII-Strings and follow usually the form of the name of the Message, Value, etc. followed by their arguments in brackets. For instance the message **NewValue \ \<2> \** would be translated to **NNewValue (String:"abcd1234") (Int:2) (VInt (Int:42))** +Messages and Responses in **LDGVNW** are serialized into ASCII-Strings and follow the form of the name of the Message, Value, etc. followed by their arguments in brackets. For instance, the message **NewValue \ \<2> \** would be translated to **NNewValue (String:"abcd1234") (Int:2) (VInt (Int:42))** -To deserialize these messages the alex and happy libraries are used. +To deserialize these messages, the alex and happy libraries are used. ### Stateless Protocol -The stateless protocol allows to directly send serialized logical messages, by establishing a new connection, sending the serialized message, waiting for a response and disconnecting afterward. By always creating new connections it can be assured that every Message gets their correct response, but establishing a new TCP connection every time a message is sent also causes a huge performance penalty. The stateless protocol creates a new temporary thread to handle each incoming message. Messages are mainly send from the main thread, in which also the interpretation occurs, with the exception of some messages like the acknowledging of a new partner address, which is sent from the temporary thread. +The stateless protocol allows sending serialized logical messages directly, by establishing a new connection, sending the serialized message, waiting for a response and disconnecting afterward. By always creating new connections, it can be assured that every message gets its correct response, but establishing a new TCP connection every time a message is sent, also causes a huge performance penalty. The stateless protocol creates a new temporary thread to handle each incoming message. Messages are primarily sent from the main thread, in which also the interpretation occurs, except for some messages like the acknowledging of a new partner address, which is sent from the temporary thread. ### Fast Protocol -The fast protocol saves a once created TCP connection and reuses it as long as it stays open. Since **LDGVNW** uses multiple threads to send Messages this can lead to Messages and Responses to be mismatched. To avoid this, each Message and Response is wrapped in a ConversationSession. +The fast protocol saves a once created TCP connection and reuses it as long as it stays open. Since **LDGVNW** uses multiple threads to send messages, this can lead to messages and responses being mismatched. To avoid this, each Message and Response is wrapped in a ConversationSession. - **ConversationMessage \ \** - **ConversationResponse \ \** - **ConversationCloseAll** The ConversationID is a random string, selected by the sender of the message and copied by the respondent. **ConversationCloseAll** is used when one party wants to close all connections to a peer, signaling to their peer that they would need to establish a new connection if they would like to talk to this port again. -Similar to the stateless protocol most messages are sent from the main thread, but since the TCP connections are saved and reused, the threads handling all messages from a given conversation partner are also reused. +Each connection gets their own thread where new incoming messages and responses are collected. Messages also get automatically handled, while responses can be picked up by the sending function, to determine its further behavior. +Similar to the stateless protocol, most messages are sent from the main thread, while some messages are sent from a connection specific thread. ## Compatibility between Internal and External Channels -Internal channels (channels in the same program, created with **new**) and external channels (channels between two programs, created with **connect** and **accept**) are handled for the most part the same way in **LDGVNW**. Every channel has a **NetworkConnection** object, which saves both incoming and outgoing messages, it also has a **ConnectionState** object, which dictates whether a **NetworkConnection** is internal or external. Should a internal connection be send to a peer, the internal connection gets converted into an external connection. Should both sides of a external connection end up in the same program, the connection will be converted to an internal connection. +Internal channels (channels in the same program, created with **new**) and external channels (channels between two programs, created with **connect** and **accept**) are handled for the most part the same way in **LDGVNW**. Every channel has a **NetworkConnection** object, which saves both incoming and outgoing messages, it also has a **ConnectionState** object, which dictates whether a **NetworkConnection** is internal or external. Should an internal connection be sent to a peer, the internal connection gets converted into an external connection. Should both sides of an external connection end up in the same program, the connection will be converted to an internal connection. + From eeae8aafff3e06cd91ad07ca940df4ece3b0c839 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 8 Mar 2023 18:29:31 +0100 Subject: [PATCH 197/229] Updated readme --- README-networking.md | 32 ++++++++++++++++++++++------- src/Networking/ThingsToLookInto.txt | 3 +++ src/ProcessEnvironmentTypes.hs | 2 ++ 3 files changed, 30 insertions(+), 7 deletions(-) create mode 100644 src/Networking/ThingsToLookInto.txt diff --git a/README-networking.md b/README-networking.md index 2e4f6a4..507e4e4 100644 --- a/README-networking.md +++ b/README-networking.md @@ -2,7 +2,7 @@ Using **LDGVNW** is a little more difficult than simply starting a single program. In addition to the requirements of **LDGV**, you also need a network connected via IPv4. Should this network span more than one device, the IP-addresses within the **LDGVNW** programs need to be altered to reflect this architecture. The current version of **LDGVNW** was tested on Fedora 37 and macOS 13.2 and should work on every recent Linux or macOS machine, it is unknown whether **LDGVNW** works on Windows machines. -To run a **LDGVNW** example program, found in the networking-examples folder, each program in the example folder needs to be run. To start the "handoff" example, you would run the following commands in different terminals or on different machines: +To run a **LDGVNW** example, found in the networking-examples folder, each program in the example folder needs to be run. To start the "handoff" example, you would run the following commands in different terminals or on different machines: - stack run ldgv -- interpret networking-examples/handoff/client.ldgvnw - stack run ldgv -- interpret networking-examples/handoff/server.ldgvnw @@ -16,7 +16,7 @@ The testNW\* scripts contain all the tests, except for the recursion test. # An Introduction to **LDGVNW**s Networking Architecture -**LDGVNW** adds networking capabilities to **LDGV**. To enable this, **LDGVNW** adds 2 new commands: +**LDGVNW** adds two new commands to **LDGV** to allow for networking capabilities: - **accept \ \** - **connect \ \ \ \** @@ -24,7 +24,7 @@ The testNW\* scripts contain all the tests, except for the recursion test. The **accept** command requires an integer as a port for others to connect and a type that will be required of a connecting connection. Once a communication partner connects with a desired type, the **accept** command will return a **VChan**. The **connect** command also requires an integer port and a desired type, but also needs to specify a string for the address of the connection partner as well as an integer for the port of the connection partner. -Just like with the **accept** command, the **connect** command will return a **VChan** once a connection has been established. +Just like with the **accept** command, the **connect** command will return a **VChan**, once a connection has been established. Important to note is that, with the current implementation, only IPv4 addresses are supported. IPv6 and Unix domain sockets could be supported in the future with a relatively low effort. @@ -52,10 +52,10 @@ With possible responses: Typing for the attributes: - **UserID** is a unique string, used to identify the logical communication partner -- **ConnectionID** is a unique string, used to identify the current physical connection to the logical communication partner +- **ConnectionID** is a unique string, used to identify the current physical connection to a logical communication partner - **Port** is a string containing the number of a port -- **Address** is a string containing the IPv4 or URL of a communication partner -- **Value**is a data-type in **LDGV**. The **VChans** are replaced with **VChanSerials** +- **Address** is a string containing the IPv4 address or URL of a communication partner +- **Value** is a data-type in **LDGV**. The **VChans** present in this **Value** are replaced with **VChanSerials** - **Value Index** is an integer containing the index of a **Value** - **Type Name** is a **TName Type** of the desired **Type** - **Type Structure** of the desired **Type** @@ -90,9 +90,27 @@ As soon as the address is established, **C** is considered successfully received ### Shutting down after completing all the instructions After **A** finishes the interpretation of their program, **A** waits until all messages it sent were acknowledged by their communication partners. After that, **A** sends a **Disconnect** message to all its peers. The **Disconnect** message is needed to avoid rewriting a large portion of the interpreter to annotate each expression with their associated output **Types**. Should the **Disconnect** message not exist, it would be theoretically possible to send a **Unit-Type** of an exhausted **Channel** to another communication partner. The recipient would now be unknowing whether their new communication partner were still online. +### Converting between **VChan**s and **VChanSerial**s + +Since **VChan**s can't be serialized directly, they need to be converted into **VChanSerial**s first. VChans have the following (simplified) architecture: + +**VChan \ \** + +the contained NetworkConnection has this architecture: + +**NetworkConnection \ \ \ \ \** + +The relevant part, for the conversion to VChanSerials, is found in the NetworkConnection. The ReadBuffer contains **Value**s that are not yet handled, while the WriteBuffer contains **Value**s that are not yet acknowledged by the communication partner. The implementation of these Buffers is based on the implementation of the Chan types of Haskell, this is also noted and acknowledged in the Buffer module. The PartnerID and OwnID are strings to identify the logical communication partner, these do not change when sent to another communication partner. Lastly, the ConnectionState contains information about whether the connection is an external connection, an internal connection, among other things. + +The VChanSerial has the following architecture: + +**VChanSerial \ \ \ \ \ \ \ \ \
\ \** + +The ReadList contains the current elements of the ReadBuffer, the ReadOffset contains the logical index of the first element of the ReadBuffer and the ReadLength is the number of all logical elements in the buffer. As an example, let's say 5 Values were received, but the first 3 already were handled, so the ReadList would contain 2 elements, the ReadOffset would be 3 and the ReadLength would be 5. The WriteList, WriteOffset and WriteLength behave analogously. The PartnerID and OwnID are directly taken from the NetworkConnection and the Address, Port and ConnectionID (from the partner) are taken from the ConnectionState. + ### A communication example -In the README-networking-communication-example.md is an example explaining the communication protocol on a concrete example +In the README-networking-communication-example.md is an example explaining the communication protocol on a concrete example. ## Serializing and Sending Messages The logical messages are serialized first, then are sent either using a fast protocol which reuses existing connections or a stateless protocol, which was primary used during development as a fallback when the fast protocol wasn't working yet. diff --git a/src/Networking/ThingsToLookInto.txt b/src/Networking/ThingsToLookInto.txt new file mode 100644 index 0000000..ccf6c18 --- /dev/null +++ b/src/Networking/ThingsToLookInto.txt @@ -0,0 +1,3 @@ +https://hackage.haskell.org/package/port-utils-0.2.1.0 + +-- Get random free port for the connect command \ No newline at end of file diff --git a/src/ProcessEnvironmentTypes.hs b/src/ProcessEnvironmentTypes.hs index b2dd399..06319d8 100644 --- a/src/ProcessEnvironmentTypes.hs +++ b/src/ProcessEnvironmentTypes.hs @@ -42,6 +42,8 @@ data Value | VDouble Double | VString String | VChan (NCon.NetworkConnection Value) (MVar.MVar Bool) + -- VChanSerials are only used to send VChans to other peers when networking + -- They are never used in normal program flow and should never be directly encountered in modules like the Interpreter | VChanSerial ([Value], Int, Int) ([Value], Int, Int) String String (String, String, String) | VSend Value | VPair Value Value -- pair of ids that map to two values From 0a95ab0ed5881aa99f7431123e8979715c519627 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 8 Mar 2023 18:44:24 +0100 Subject: [PATCH 198/229] Update README-networking.md --- README-networking.md | 36 +++++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 15 deletions(-) diff --git a/README-networking.md b/README-networking.md index 507e4e4..12011f1 100644 --- a/README-networking.md +++ b/README-networking.md @@ -28,9 +28,9 @@ Just like with the **accept** command, the **connect** command will return a **V Important to note is that, with the current implementation, only IPv4 addresses are supported. IPv6 and Unix domain sockets could be supported in the future with a relatively low effort. -## The Logical Communication Architecture +# The Logical Communication Architecture -### Messages and Responses +## Messages and Responses In **LDGVNW**, there are 7 possible **Messages** and 4 possible **Responses**. The messages are: @@ -60,13 +60,13 @@ Typing for the attributes: - **Type Name** is a **TName Type** of the desired **Type** - **Type Structure** of the desired **Type** -### Establishing a new Connection +## Establishing a new Connection As soon as **B** opens up their port with the **accept** command. **A** can **connect**, by sending an **Introduce** message to **B**. This message contains the unique ID of **A**, **A**s port, as well as the name and structure of the desired communication **Type**. **B** then answers with a **OkayIntroduce** response, sharing their own unique ID with **A**. Following that, **A** and **B** can **send** and **recv** values analog to **Channels** created with the **new** command. -### Sending messages over a Connection +## Sending messages over a Connection When communication partner **A** executes a send instruction to **send** Value **V** to **B**, **A** first analyses **V**. Should **V** be or contain a Channel **C**, **A** will set a flag for in **C** to redirect new messages to the address of **B**. After that, **C** will be converted to a serializable form **CS**. @@ -76,21 +76,21 @@ And contacts the communication partner of each Channel, to inform them that thei After this, **B** sends an acknowledgment (**AcknowledgeValue** message) back to **A**, which finalizes the sending of **V**. **A** can now remove **V** out of its write-buffer. -### Responding to Messages +## Responding to Messages Except for the **Introduce** message, every message should be answered with an **Okay** response. Exceptions to that are **Redirect** responses, which are used when a message is sent to an outdated address or **Wait** responses, which are sent when a message cannot be handled at the current moment. This can happen when the communication partner is already handling a message in a critical section, or a communication partner is currently in the progress of sending the Channel which the message is sent to. -### Informing communication partners of a communication partner change +## Informing communication partners of a communication partner change If there is a Channel **C** between **A** and **B** and **A** sends their side of the Channel to **D**, **B** needs to be made aware of that. To archive this, **D** sends a **NewPartnerAddress** message to **B**. This message contains the server port of **D** and a new ConnectionID **DC** for **D**. **B** then replies with a **AcknowledgePartnerAddress** message, repeating **DC**. As soon as the address is established, **C** is considered successfully received by **D**. -### Shutting down after completing all the instructions +## Shutting down after completing all the instructions After **A** finishes the interpretation of their program, **A** waits until all messages it sent were acknowledged by their communication partners. After that, **A** sends a **Disconnect** message to all its peers. The **Disconnect** message is needed to avoid rewriting a large portion of the interpreter to annotate each expression with their associated output **Types**. Should the **Disconnect** message not exist, it would be theoretically possible to send a **Unit-Type** of an exhausted **Channel** to another communication partner. The recipient would now be unknowing whether their new communication partner were still online. -### Converting between **VChan**s and **VChanSerial**s +## Converting between **VChan**s and **VChanSerial**s Since **VChan**s can't be serialized directly, they need to be converted into **VChanSerial**s first. VChans have the following (simplified) architecture: @@ -106,24 +106,28 @@ The VChanSerial has the following architecture: **VChanSerial \ \ \ \ \ \ \ \ \
\ \** -The ReadList contains the current elements of the ReadBuffer, the ReadOffset contains the logical index of the first element of the ReadBuffer and the ReadLength is the number of all logical elements in the buffer. As an example, let's say 5 Values were received, but the first 3 already were handled, so the ReadList would contain 2 elements, the ReadOffset would be 3 and the ReadLength would be 5. The WriteList, WriteOffset and WriteLength behave analogously. The PartnerID and OwnID are directly taken from the NetworkConnection and the Address, Port and ConnectionID (from the partner) are taken from the ConnectionState. +The ReadList contains the current elements of the ReadBuffer, the ReadOffset contains the logical index of the first element of the ReadBuffer, and the ReadLength is the number of all logical elements in the buffer. As an example, let's say 5 Values were received, but the first 3 already were handled, so the ReadList would contain 2 elements, the ReadOffset would be 3 and the ReadLength would be 5. The WriteList, WriteOffset and WriteLength behave analogously. The PartnerID and OwnID are directly taken from the NetworkConnection and the Address, Port and ConnectionID (from the partner) are taken from the ConnectionState. -### A communication example +To convert a VChanSerial to a VChan an empty VChan is simply filled with the data provided by the VChanSerial. + +It is important to note that VChans only should be serialized after their ConnectionState has been set to **Redirect**. This freezes the VChan, as it can no longer receive new messages. This way it can be assured, that at the time of receipt, both the original VChan and the one generated from the VChanSerial contain the identical data. + +## A communication example In the README-networking-communication-example.md is an example explaining the communication protocol on a concrete example. -## Serializing and Sending Messages +# Serializing and Sending Messages The logical messages are serialized first, then are sent either using a fast protocol which reuses existing connections or a stateless protocol, which was primary used during development as a fallback when the fast protocol wasn't working yet. -### Serialization +## Serialization Messages and Responses in **LDGVNW** are serialized into ASCII-Strings and follow the form of the name of the Message, Value, etc. followed by their arguments in brackets. For instance, the message **NewValue \ \<2> \** would be translated to **NNewValue (String:"abcd1234") (Int:2) (VInt (Int:42))** To deserialize these messages, the alex and happy libraries are used. -### Stateless Protocol +## Stateless Protocol The stateless protocol allows sending serialized logical messages directly, by establishing a new connection, sending the serialized message, waiting for a response and disconnecting afterward. By always creating new connections, it can be assured that every message gets its correct response, but establishing a new TCP connection every time a message is sent, also causes a huge performance penalty. The stateless protocol creates a new temporary thread to handle each incoming message. Messages are primarily sent from the main thread, in which also the interpretation occurs, except for some messages like the acknowledging of a new partner address, which is sent from the temporary thread. -### Fast Protocol +## Fast Protocol The fast protocol saves a once created TCP connection and reuses it as long as it stays open. Since **LDGVNW** uses multiple threads to send messages, this can lead to messages and responses being mismatched. To avoid this, each Message and Response is wrapped in a ConversationSession. - **ConversationMessage \ \** @@ -134,7 +138,9 @@ The ConversationID is a random string, selected by the sender of the message and Each connection gets their own thread where new incoming messages and responses are collected. Messages also get automatically handled, while responses can be picked up by the sending function, to determine its further behavior. Similar to the stateless protocol, most messages are sent from the main thread, while some messages are sent from a connection specific thread. -## Compatibility between Internal and External Channels +# Compatibility between Internal and External Channels Internal channels (channels in the same program, created with **new**) and external channels (channels between two programs, created with **connect** and **accept**) are handled for the most part the same way in **LDGVNW**. Every channel has a **NetworkConnection** object, which saves both incoming and outgoing messages, it also has a **ConnectionState** object, which dictates whether a **NetworkConnection** is internal or external. Should an internal connection be sent to a peer, the internal connection gets converted into an external connection. Should both sides of an external connection end up in the same program, the connection will be converted to an internal connection. + + From d6348982c92b03545bad12e5f7e4c6933032335d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 8 Mar 2023 18:47:31 +0100 Subject: [PATCH 199/229] Update README-networking.md --- README-networking.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README-networking.md b/README-networking.md index 12011f1..96aa369 100644 --- a/README-networking.md +++ b/README-networking.md @@ -14,7 +14,7 @@ To test all the different test-cases in an easier way, they can be automatically The testNW\* scripts contain all the tests, except for the recursion test. -# An Introduction to **LDGVNW**s Networking Architecture +# An Introduction to **LDGVNW** **LDGVNW** adds two new commands to **LDGV** to allow for networking capabilities: From d757f49af94b7614d9b6200a9aeea7fad35a7fb6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 9 Mar 2023 12:03:20 +0100 Subject: [PATCH 200/229] Update README-networking.md --- README-networking.md | 48 ++++++++++++++++++++++---------------------- 1 file changed, 24 insertions(+), 24 deletions(-) diff --git a/README-networking.md b/README-networking.md index 96aa369..7da7112 100644 --- a/README-networking.md +++ b/README-networking.md @@ -4,9 +4,9 @@ Using **LDGVNW** is a little more difficult than simply starting a single progra To run a **LDGVNW** example, found in the networking-examples folder, each program in the example folder needs to be run. To start the "handoff" example, you would run the following commands in different terminals or on different machines: -- stack run ldgv -- interpret networking-examples/handoff/client.ldgvnw -- stack run ldgv -- interpret networking-examples/handoff/server.ldgvnw -- stack run ldgv -- interpret networking-examples/handoff/handoff.ldgvnw +- `stack run ldgv -- interpret networking-examples/handoff/client.ldgvnw` +- `stack run ldgv -- interpret networking-examples/handoff/server.ldgvnw` +- `stack run ldgv -- interpret networking-examples/handoff/handoff.ldgvnw` The order in which these commands are executed is not relevant. @@ -18,8 +18,8 @@ The testNW\* scripts contain all the tests, except for the recursion test. **LDGVNW** adds two new commands to **LDGV** to allow for networking capabilities: -- **accept \ \** -- **connect \ \ \ \** +- `accept ` +- `connect ` The **accept** command requires an integer as a port for others to connect and a type that will be required of a connecting connection. Once a communication partner connects with a desired type, the **accept** command will return a **VChan**. @@ -34,20 +34,20 @@ IPv6 and Unix domain sockets could be supported in the future with a relatively In **LDGVNW**, there are 7 possible **Messages** and 4 possible **Responses**. The messages are: -- **Introduce \ \ \ \** -- **NewValue \ \ \** -- **RequestValue \ \** -- **AcknowledgeValue \ \** -- **NewPartnerAddress \ \ \** -- **AcknowledgePartnerAddress \ \** -- **Disconnect \** +- `Introduce ` +- `NewValue ` +- `RequestValue ` +- `AcknowledgeValue ` +- `NewPartnerAddress ` +- `AcknowledgePartnerAddress ` +- `Disconnect ` With possible responses: -- **Redirect \ \** -- **Okay** -- **OkayIntroduce \** -- **Wait** +- `Redirect ` +- `Okay` +- `OkayIntroduce ` +- `Wait` Typing for the attributes: @@ -94,17 +94,17 @@ After **A** finishes the interpretation of their program, **A** waits until all Since **VChan**s can't be serialized directly, they need to be converted into **VChanSerial**s first. VChans have the following (simplified) architecture: -**VChan \ \** +`VChan ` the contained NetworkConnection has this architecture: -**NetworkConnection \ \ \ \ \** +`NetworkConnection ` The relevant part, for the conversion to VChanSerials, is found in the NetworkConnection. The ReadBuffer contains **Value**s that are not yet handled, while the WriteBuffer contains **Value**s that are not yet acknowledged by the communication partner. The implementation of these Buffers is based on the implementation of the Chan types of Haskell, this is also noted and acknowledged in the Buffer module. The PartnerID and OwnID are strings to identify the logical communication partner, these do not change when sent to another communication partner. Lastly, the ConnectionState contains information about whether the connection is an external connection, an internal connection, among other things. The VChanSerial has the following architecture: -**VChanSerial \ \ \ \ \ \ \ \ \
\ \** +`VChanSerial
` The ReadList contains the current elements of the ReadBuffer, the ReadOffset contains the logical index of the first element of the ReadBuffer, and the ReadLength is the number of all logical elements in the buffer. As an example, let's say 5 Values were received, but the first 3 already were handled, so the ReadList would contain 2 elements, the ReadOffset would be 3 and the ReadLength would be 5. The WriteList, WriteOffset and WriteLength behave analogously. The PartnerID and OwnID are directly taken from the NetworkConnection and the Address, Port and ConnectionID (from the partner) are taken from the ConnectionState. @@ -114,13 +114,13 @@ It is important to note that VChans only should be serialized after their Connec ## A communication example -In the README-networking-communication-example.md is an example explaining the communication protocol on a concrete example. +In the [communication example](#README-networking-communication-example.md) gives a concrete example for the communication protocol. # Serializing and Sending Messages The logical messages are serialized first, then are sent either using a fast protocol which reuses existing connections or a stateless protocol, which was primary used during development as a fallback when the fast protocol wasn't working yet. ## Serialization -Messages and Responses in **LDGVNW** are serialized into ASCII-Strings and follow the form of the name of the Message, Value, etc. followed by their arguments in brackets. For instance, the message **NewValue \ \<2> \** would be translated to **NNewValue (String:"abcd1234") (Int:2) (VInt (Int:42))** +Messages and Responses in **LDGVNW** are serialized into ASCII-Strings and follow the form of the name of the Message, Value, etc. followed by their arguments in brackets. For instance, the message `NewValue <2> ` would be translated to `NNewValue (String:"abcd1234") (Int:2) (VInt (Int:42))` To deserialize these messages, the alex and happy libraries are used. @@ -130,9 +130,9 @@ The stateless protocol allows sending serialized logical messages directly, by e ## Fast Protocol The fast protocol saves a once created TCP connection and reuses it as long as it stays open. Since **LDGVNW** uses multiple threads to send messages, this can lead to messages and responses being mismatched. To avoid this, each Message and Response is wrapped in a ConversationSession. -- **ConversationMessage \ \** -- **ConversationResponse \ \** -- **ConversationCloseAll** +- `ConversationMessage ` +- `ConversationResponse ` +- `ConversationCloseAll` The ConversationID is a random string, selected by the sender of the message and copied by the respondent. **ConversationCloseAll** is used when one party wants to close all connections to a peer, signaling to their peer that they would need to establish a new connection if they would like to talk to this port again. Each connection gets their own thread where new incoming messages and responses are collected. Messages also get automatically handled, while responses can be picked up by the sending function, to determine its further behavior. From 5a21127a6902d19719ca669753be96be0451d17f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 9 Mar 2023 12:05:49 +0100 Subject: [PATCH 201/229] Update README-networking.md --- README-networking.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README-networking.md b/README-networking.md index 7da7112..bef1d7d 100644 --- a/README-networking.md +++ b/README-networking.md @@ -114,7 +114,7 @@ It is important to note that VChans only should be serialized after their Connec ## A communication example -In the [communication example](#README-networking-communication-example.md) gives a concrete example for the communication protocol. +In the [communication example](README-networking-communication-example.md) gives a concrete example for the communication protocol. # Serializing and Sending Messages The logical messages are serialized first, then are sent either using a fast protocol which reuses existing connections or a stateless protocol, which was primary used during development as a fallback when the fast protocol wasn't working yet. From d4c7f8421ae34665b89fd9fed1e0e9c6334e6a03 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 9 Mar 2023 13:08:12 +0100 Subject: [PATCH 202/229] Added information about LDGVNW to the readme --- README-networking.md | 7 +++++++ README.md | 4 ++++ 2 files changed, 11 insertions(+) diff --git a/README-networking.md b/README-networking.md index bef1d7d..a9972bc 100644 --- a/README-networking.md +++ b/README-networking.md @@ -112,6 +112,13 @@ To convert a VChanSerial to a VChan an empty VChan is simply filled with the dat It is important to note that VChans only should be serialized after their ConnectionState has been set to **Redirect**. This freezes the VChan, as it can no longer receive new messages. This way it can be assured, that at the time of receipt, both the original VChan and the one generated from the VChanSerial contain the identical data. +## Why Values are Acknowledged + +LDGVNW has separate messages for sending a Value (NewValue) and acknowledging a Value (AcknowledgeValue). Simply knowing that the other party has received a Value, isn't enough when Channels are involved. +Let's say there is a Channel **C**, between **A** and **B**. **A** sends their end of **C** to **D** and at the same time **B** sends their end of **C** to **E**. Since the sending of the Channel ends, happened simultaneously, **D** still thinks they are talking to **B** and **E** thinks they are talking to **A**. Should **A** and **B** now go offline, before either **D** or **E**, can contact them to find out where they redirected their connections to, **D** and **E** will not be able to connect. Since acknowledgements are only sent after a sent Channel has been reconnected, it can be assured that **D** and **E** are connected, before **A** and **B** can go offline. + +It would be also possible to use a Response to the NewValue message, to signal that the Value got acknowledged, but I decided to split this process into two messages, since the acknowledging can take long time, compared to other messages. + ## A communication example In the [communication example](README-networking-communication-example.md) gives a concrete example for the communication protocol. diff --git a/README.md b/README.md index d6baa47..dcd3add 100644 --- a/README.md +++ b/README.md @@ -80,6 +80,10 @@ properly curried, the top level symbol must have a type signature matching `LDST_fp0_t` and the name must match the name transformations pointed out above. (NB: this allows to subvert the type system, in all good and bad ways.) +## LDGVNW + +LDGVNW is a extension to LDGV, more can be read [here](README-networking.md). + ## Testing You can run the full test suite by: From c1205add46248e9413463c8fd60d81c321493be3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 9 Mar 2023 14:05:15 +0100 Subject: [PATCH 203/229] Cleanup and added info about Buffer to LICENSE --- LICENSE | 35 ++++++++++++++++ README-networking.md | 86 +++++++++++++++++++------------------- src/Networking/Incoming.hs | 37 ---------------- 3 files changed, 78 insertions(+), 80 deletions(-) diff --git a/LICENSE b/LICENSE index f016c61..37de541 100644 --- a/LICENSE +++ b/LICENSE @@ -78,3 +78,38 @@ AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +----------------------------------------------------------------------------- +The Buffer in the Networking module, is based on the Chan module by The University of Glasgow + +The Glasgow Haskell Compiler License + +Copyright 2004, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. \ No newline at end of file diff --git a/README-networking.md b/README-networking.md index a9972bc..8e95e24 100644 --- a/README-networking.md +++ b/README-networking.md @@ -1,8 +1,8 @@ -# How to run **LDGVNW** +# How to run LDGVNW -Using **LDGVNW** is a little more difficult than simply starting a single program. In addition to the requirements of **LDGV**, you also need a network connected via IPv4. Should this network span more than one device, the IP-addresses within the **LDGVNW** programs need to be altered to reflect this architecture. The current version of **LDGVNW** was tested on Fedora 37 and macOS 13.2 and should work on every recent Linux or macOS machine, it is unknown whether **LDGVNW** works on Windows machines. +Using LDGVNW is a little more difficult than simply starting a single program. In addition to the requirements of LDGV, you also need a network connected via IPv4. Should this network span more than one device, the IP-addresses within the LDGVNW programs need to be altered to reflect this architecture. The current version of LDGVNW was tested on Fedora 37 and macOS 13.2 and should work on every recent Linux or macOS machine, it is unknown whether LDGVNW works on Windows machines. -To run a **LDGVNW** example, found in the networking-examples folder, each program in the example folder needs to be run. To start the "handoff" example, you would run the following commands in different terminals or on different machines: +To run a LDGVNW example, found in the networking-examples folder, each program in the example folder needs to be run. To start the "handoff" example, you would run the following commands in different terminals or on different machines: - `stack run ldgv -- interpret networking-examples/handoff/client.ldgvnw` - `stack run ldgv -- interpret networking-examples/handoff/server.ldgvnw` @@ -14,24 +14,24 @@ To test all the different test-cases in an easier way, they can be automatically The testNW\* scripts contain all the tests, except for the recursion test. -# An Introduction to **LDGVNW** +# An Introduction to LDGVNW -**LDGVNW** adds two new commands to **LDGV** to allow for networking capabilities: +LDGVNW adds two new commands to LDGV to allow for networking capabilities: - `accept ` - `connect ` -The **accept** command requires an integer as a port for others to connect and a type that will be required of a connecting connection. -Once a communication partner connects with a desired type, the **accept** command will return a **VChan**. -The **connect** command also requires an integer port and a desired type, but also needs to specify a string for the address of the connection partner as well as an integer for the port of the connection partner. -Just like with the **accept** command, the **connect** command will return a **VChan**, once a connection has been established. +The accept command requires an integer as a port for others to connect and a type that will be required of a connecting connection. +Once a communication partner connects with a desired type, the accept command will return a VChan. +The connect command also requires an integer port and a desired type, but also needs to specify a string for the address of the connection partner as well as an integer for the port of the connection partner. +Just like with the accept command, the connect command will return a VChan, once a connection has been established. Important to note is that, with the current implementation, only IPv4 addresses are supported. IPv6 and Unix domain sockets could be supported in the future with a relatively low effort. # The Logical Communication Architecture ## Messages and Responses -In **LDGVNW**, there are 7 possible **Messages** and 4 possible **Responses**. +In LDGVNW, there are 7 possible Messages and 4 possible Responses. The messages are: - `Introduce ` @@ -55,52 +55,52 @@ Typing for the attributes: - **ConnectionID** is a unique string, used to identify the current physical connection to a logical communication partner - **Port** is a string containing the number of a port - **Address** is a string containing the IPv4 address or URL of a communication partner -- **Value** is a data-type in **LDGV**. The **VChans** present in this **Value** are replaced with **VChanSerials** -- **Value Index** is an integer containing the index of a **Value** -- **Type Name** is a **TName Type** of the desired **Type** -- **Type Structure** of the desired **Type** +- **Value** is a data-type in LDGV. The VChans present in this Value are replaced with VChanSerials +- **Value Index** is an integer containing the index of a Value +- **Type Name** is a TName Type of the desired Type +- **Type Structure** of the desired Type ## Establishing a new Connection -As soon as **B** opens up their port with the **accept** command. **A** can **connect**, by sending an **Introduce** message to **B**. -This message contains the unique ID of **A**, **A**s port, as well as the name and structure of the desired communication **Type**. -**B** then answers with a **OkayIntroduce** response, sharing their own unique ID with **A**. -Following that, **A** and **B** can **send** and **recv** values analog to **Channels** created with the **new** command. +As soon as B opens up their port with the accept command. A can connect, by sending an Introduce message to B. +This message contains the unique ID of A, As port, as well as the name and structure of the desired communication Type. +B then answers with a OkayIntroduce response, sharing their own unique ID with A. +Following that, A and B can send and recv values analog to Channels created with the new command. ## Sending messages over a Connection -When communication partner **A** executes a send instruction to **send** Value **V** to **B**, **A** first analyses **V**. -Should **V** be or contain a Channel **C**, **A** will set a flag for in **C** to redirect new messages to the address of **B**. -After that, **C** will be converted to a serializable form **CS**. -With every channel now being in a form which can be sent over the network, **A** now writes **V** to its write-buffer and sends **B** a **NewValue** message containing **V**. -Upon receiving **V** as **B** with the **recv** instruction, **B** now undoes the conversion of every Channel in **V** from **CS** to **C**. -And contacts the communication partner of each Channel, to inform them that their new communication partner is now **B** instead of **A**. -After this, **B** sends an acknowledgment (**AcknowledgeValue** message) back to **A**, which finalizes the sending of **V**. -**A** can now remove **V** out of its write-buffer. +When communication partner A executes a send instruction to send Value V to B, A first analyses V. +Should V be or contain a Channel C, A will set a flag for in C to redirect new messages to the address of B. +After that, C will be converted to a serializable form CS. +With every channel now being in a form which can be sent over the network, A now writes V to its write-buffer and sends B a NewValue message containing V. +Upon receiving V as B with the recv instruction, B now undoes the conversion of every Channel in V from CS to C. +And contacts the communication partner of each Channel, to inform them that their new communication partner is now B instead of A. +After this, B sends an acknowledgment (AcknowledgeValue message) back to A, which finalizes the sending of V. +A can now remove V out of its write-buffer. ## Responding to Messages -Except for the **Introduce** message, every message should be answered with an **Okay** response. -Exceptions to that are **Redirect** responses, which are used when a message is sent to an outdated address or **Wait** responses, which are sent when a message cannot be handled at the current moment. +Except for the Introduce message, every message should be answered with an Okay response. +Exceptions to that are Redirect responses, which are used when a message is sent to an outdated address or Wait responses, which are sent when a message cannot be handled at the current moment. This can happen when the communication partner is already handling a message in a critical section, or a communication partner is currently in the progress of sending the Channel which the message is sent to. ## Informing communication partners of a communication partner change -If there is a Channel **C** between **A** and **B** and **A** sends their side of the Channel to **D**, **B** needs to be made aware of that. -To archive this, **D** sends a **NewPartnerAddress** message to **B**. This message contains the server port of **D** and a new ConnectionID **DC** for **D**. -**B** then replies with a **AcknowledgePartnerAddress** message, repeating **DC**. -As soon as the address is established, **C** is considered successfully received by **D**. +If there is a Channel C between A and B and A sends their side of the Channel to D, B needs to be made aware of that. +To archive this, D sends a NewPartnerAddress message to B. This message contains the server port of D and a new ConnectionID DC for D. +B then replies with a AcknowledgePartnerAddress message, repeating DC. +As soon as the address is established, C is considered successfully received by D. ## Shutting down after completing all the instructions -After **A** finishes the interpretation of their program, **A** waits until all messages it sent were acknowledged by their communication partners. After that, **A** sends a **Disconnect** message to all its peers. The **Disconnect** message is needed to avoid rewriting a large portion of the interpreter to annotate each expression with their associated output **Types**. Should the **Disconnect** message not exist, it would be theoretically possible to send a **Unit-Type** of an exhausted **Channel** to another communication partner. The recipient would now be unknowing whether their new communication partner were still online. +After A finishes the interpretation of their program, A waits until all messages it sent were acknowledged by their communication partners. After that, A sends a Disconnect message to all its peers. The Disconnect message is needed to avoid rewriting a large portion of the interpreter to annotate each expression with their associated output Types. Should the Disconnect message not exist, it would be theoretically possible to send a Unit-Type of an exhausted Channel to another communication partner. The recipient would now be unknowing whether their new communication partner were still online. -## Converting between **VChan**s and **VChanSerial**s +## Converting between VChans and VChanSerials -Since **VChan**s can't be serialized directly, they need to be converted into **VChanSerial**s first. VChans have the following (simplified) architecture: +Since VChans can't be serialized directly, they need to be converted into VChanSerials first. VChans have the following (simplified) architecture: `VChan ` -the contained NetworkConnection has this architecture: +The contained NetworkConnection has this architecture: `NetworkConnection ` -The relevant part, for the conversion to VChanSerials, is found in the NetworkConnection. The ReadBuffer contains **Value**s that are not yet handled, while the WriteBuffer contains **Value**s that are not yet acknowledged by the communication partner. The implementation of these Buffers is based on the implementation of the Chan types of Haskell, this is also noted and acknowledged in the Buffer module. The PartnerID and OwnID are strings to identify the logical communication partner, these do not change when sent to another communication partner. Lastly, the ConnectionState contains information about whether the connection is an external connection, an internal connection, among other things. +The relevant part, for the conversion to VChanSerials, is found in the NetworkConnection. The ReadBuffer contains Values that are not yet handled, while the WriteBuffer contains Values that are not yet acknowledged by the communication partner. The implementation of these Buffers is based on the implementation of the Chan types of Haskell, this is also noted and acknowledged in the Buffer module. The PartnerID and OwnID are strings to identify the logical communication partner, these do not change when sent to another communication partner. Lastly, the ConnectionState contains information about whether the connection is an external connection, an internal connection, among other things. The VChanSerial has the following architecture: @@ -110,12 +110,12 @@ The ReadList contains the current elements of the ReadBuffer, the ReadOffset con To convert a VChanSerial to a VChan an empty VChan is simply filled with the data provided by the VChanSerial. -It is important to note that VChans only should be serialized after their ConnectionState has been set to **Redirect**. This freezes the VChan, as it can no longer receive new messages. This way it can be assured, that at the time of receipt, both the original VChan and the one generated from the VChanSerial contain the identical data. +It is important to note that VChans only should be serialized after their ConnectionState has been set to Redirect. This freezes the VChan, as it can no longer receive new messages. This way it can be assured, that at the time of receipt, both the original VChan and the one generated from the VChanSerial contain the identical data. ## Why Values are Acknowledged LDGVNW has separate messages for sending a Value (NewValue) and acknowledging a Value (AcknowledgeValue). Simply knowing that the other party has received a Value, isn't enough when Channels are involved. -Let's say there is a Channel **C**, between **A** and **B**. **A** sends their end of **C** to **D** and at the same time **B** sends their end of **C** to **E**. Since the sending of the Channel ends, happened simultaneously, **D** still thinks they are talking to **B** and **E** thinks they are talking to **A**. Should **A** and **B** now go offline, before either **D** or **E**, can contact them to find out where they redirected their connections to, **D** and **E** will not be able to connect. Since acknowledgements are only sent after a sent Channel has been reconnected, it can be assured that **D** and **E** are connected, before **A** and **B** can go offline. +Let's say there is a Channel C, between A and B. A sends their end of C to D and at the same time B sends their end of C to E. Since the sending of the Channel ends, happened simultaneously, D still thinks they are talking to B and E thinks they are talking to A. Should A and B now go offline, before either D or E, can contact them to find out where they redirected their connections to, D and E will not be able to connect. Since acknowledgements are only sent after a sent Channel has been reconnected, it can be assured that D and E are connected, before A and B can go offline. It would be also possible to use a Response to the NewValue message, to signal that the Value got acknowledged, but I decided to split this process into two messages, since the acknowledging can take long time, compared to other messages. @@ -127,7 +127,7 @@ In the [communication example](README-networking-communication-example.md) gives The logical messages are serialized first, then are sent either using a fast protocol which reuses existing connections or a stateless protocol, which was primary used during development as a fallback when the fast protocol wasn't working yet. ## Serialization -Messages and Responses in **LDGVNW** are serialized into ASCII-Strings and follow the form of the name of the Message, Value, etc. followed by their arguments in brackets. For instance, the message `NewValue <2> ` would be translated to `NNewValue (String:"abcd1234") (Int:2) (VInt (Int:42))` +Messages and Responses in LDGVNW are serialized into ASCII-Strings and follow the form of the name of the Message, Value, etc. followed by their arguments in brackets. For instance, the message `NewValue <2> ` would be translated to `NNewValue (String:"abcd1234") (Int:2) (VInt (Int:42))` To deserialize these messages, the alex and happy libraries are used. @@ -135,19 +135,19 @@ To deserialize these messages, the alex and happy libraries are used. The stateless protocol allows sending serialized logical messages directly, by establishing a new connection, sending the serialized message, waiting for a response and disconnecting afterward. By always creating new connections, it can be assured that every message gets its correct response, but establishing a new TCP connection every time a message is sent, also causes a huge performance penalty. The stateless protocol creates a new temporary thread to handle each incoming message. Messages are primarily sent from the main thread, in which also the interpretation occurs, except for some messages like the acknowledging of a new partner address, which is sent from the temporary thread. ## Fast Protocol -The fast protocol saves a once created TCP connection and reuses it as long as it stays open. Since **LDGVNW** uses multiple threads to send messages, this can lead to messages and responses being mismatched. To avoid this, each Message and Response is wrapped in a ConversationSession. +The fast protocol saves a once created TCP connection and reuses it as long as it stays open. Since LDGVNW uses multiple threads to send messages, this can lead to messages and responses being mismatched. To avoid this, each Message and Response is wrapped in a ConversationSession. - `ConversationMessage ` - `ConversationResponse ` - `ConversationCloseAll` -The ConversationID is a random string, selected by the sender of the message and copied by the respondent. **ConversationCloseAll** is used when one party wants to close all connections to a peer, signaling to their peer that they would need to establish a new connection if they would like to talk to this port again. +The ConversationID is a random string, selected by the sender of the message and copied by the respondent. ConversationCloseAll is used when one party wants to close all connections to a peer, signaling to their peer that they would need to establish a new connection if they would like to talk to this port again. Each connection gets their own thread where new incoming messages and responses are collected. Messages also get automatically handled, while responses can be picked up by the sending function, to determine its further behavior. Similar to the stateless protocol, most messages are sent from the main thread, while some messages are sent from a connection specific thread. # Compatibility between Internal and External Channels -Internal channels (channels in the same program, created with **new**) and external channels (channels between two programs, created with **connect** and **accept**) are handled for the most part the same way in **LDGVNW**. Every channel has a **NetworkConnection** object, which saves both incoming and outgoing messages, it also has a **ConnectionState** object, which dictates whether a **NetworkConnection** is internal or external. Should an internal connection be sent to a peer, the internal connection gets converted into an external connection. Should both sides of an external connection end up in the same program, the connection will be converted to an internal connection. +Internal channels (channels in the same program, created with new) and external channels (channels between two programs, created with connect and accept) are handled for the most part the same way in LDGVNW. Every channel has a NetworkConnection object, which saves both incoming and outgoing messages, it also has a ConnectionState object, which dictates whether a NetworkConnection is internal or external. Should an internal connection be sent to a peer, the internal connection gets converted into an external connection. Should both sides of an external connection end up in the same program, the connection will be converted to an internal connection. diff --git a/src/Networking/Incoming.hs b/src/Networking/Incoming.hs index 6e27c8a..c40f0d8 100644 --- a/src/Networking/Incoming.hs +++ b/src/Networking/Incoming.hs @@ -173,7 +173,6 @@ contactNewPeers vchansmvar activeCons ownport ownNC = searchVChans (handleVChan -- Check whether their partner is also registered and connected on this instance, if so convert the connection into a emulated one vchanconnections <- MVar.readMVar vchansmvar let userid = ncOwnUserID nc - let partnerid = ncPartnerUserID nc let mbypartner = Map.lookup userid vchanconnections case mbypartner of Just partner -> do @@ -188,35 +187,22 @@ contactNewPeers vchansmvar activeCons ownport ownNC = searchVChans (handleVChan MVar.putMVar (ncConnectionState partner) $ Emulated ownConID partConID True _ <- MVar.takeMVar $ ncConnectionState nc MVar.putMVar (ncConnectionState nc) $ Emulated partConID ownConID True - {-setReadyForUse partner True - Config.traceNetIO $ "Set: " ++ ncOwnUserID partner ++ " ready for use" - setReadyForUse nc True - Config.traceNetIO $ "Set: " ++ ncOwnUserID nc ++ " ready for use"-} SSem.signal (ncHandlingIncomingMessage partner) return True _ -> do -- Nothing to do here, we no longer own the partner MVar.putMVar (ncConnectionState partner) connectionState SSem.signal (ncHandlingIncomingMessage partner) - -- setReadyForUse nc True - -- Config.traceNetIO $ "Set: " ++ ncOwnUserID nc ++ " ready for use" sendSuccess <- NO.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) $ -2 if sendSuccess then return False else do threadDelay 100000 return False - -- putStrLn "Trying to lookup future messages" - -- futureRecieveFromAllContainsPartner vchansmvar ownNC partnerid Nothing -> do -- Their partner isnt registered in this instance - -- setReadyForUse nc True - -- Config.traceNetIO $ "Set: " ++ ncOwnUserID nc ++ " ready for use" sendSuccess <- NO.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) $ -2 if sendSuccess then return False else do threadDelay 100000 return False - -- putStrLn "Trying to lookup future messages" - -- futureRecieveFromAllContainsPartner vchansmvar ownNC partnerid - -- return False _ -> return True hostaddressTypeToString :: HostAddress -> String @@ -267,22 +253,6 @@ insertVChansIntoVChanCons vchansmvar readyForUse = searchVChans (handleSerial vc return () _ -> return () -{- -replaceVChanSerial :: NMC.ActiveConnections -> VChanConnections -> Value -> IO Value -replaceVChanSerial activeCons mvar input = modifyVChans (handleSerial activeCons mvar) input - where - handleSerial :: NMC.ActiveConnections -> VChanConnections -> Value -> IO Value - handleSerial activeCons mvar input = case input of - VChanSerial r w p o c -> do - networkconnection <- createNetworkConnection r w p o c - ncmap <- MVar.takeMVar mvar - MVar.putMVar mvar $ Map.insert p networkconnection ncmap - used<- MVar.newEmptyMVar - MVar.putMVar used False - return $ VChan networkconnection used - _ -> return input --} - replaceVChanSerial :: NMC.ActiveConnections -> VChanConnections -> Value -> IO Value replaceVChanSerial activeCons mvar input = modifyVChans (handleSerial activeCons mvar) input where @@ -292,13 +262,6 @@ replaceVChanSerial activeCons mvar input = modifyVChans (handleSerial activeCons ncmap <- MVar.readMVar mvar case Map.lookup p ncmap of Nothing -> do - {-networkconnection <- createNetworkConnection r w p o c - ncmap <- MVar.takeMVar mvar - MVar.putMVar mvar $ Map.insert p networkconnection ncmap - used<- MVar.newMVar False - return $ VChan networkconnection used-} - -- This can lead to the value being overwritten - -- We simply need to wait for the other thread to finish threadDelay 1000 handleSerial activeCons mvar input From 34da2246ca2add71498f1a784ecc250baf2d2523 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 9 Mar 2023 14:18:23 +0100 Subject: [PATCH 204/229] Update Incoming.hs --- src/Networking/Incoming.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Networking/Incoming.hs b/src/Networking/Incoming.hs index c40f0d8..c01344d 100644 --- a/src/Networking/Incoming.hs +++ b/src/Networking/Incoming.hs @@ -320,8 +320,8 @@ tryToAcknowledgeValue vchanconsvar activeCons networkconnection valueToAcknowled let mbypartner = Map.lookup ownid vchancons case mbypartner of Just partner -> do - -- NB.serialize (ncWrite partner) >>= \x -> Config.traceNetIO $ "Emulated "++ show unclean ++ " before acknowlegment: " ++ show x + -- NB.serialize (ncWrite partner) >>= \x -> Config.traceNetIO $ "Emulated "++ show unclean ++ " before acknowledgment: " ++ show x NB.updateAcknowledgements (ncWrite partner) valueToAcknowledge return True - _ -> Config.traceNetIO "Something went wrong when acknowleding value of emulated connection" >> return False + _ -> Config.traceNetIO "Something went wrong when acknowledging value of emulated connection" >> return False _ -> return True \ No newline at end of file From d800ebba669af54fbd77543b81411bf77546cb0b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 9 Mar 2023 17:19:20 +0100 Subject: [PATCH 205/229] Receive is now spelled correctly --- TODO | 1 - src/Interpreter.hs | 2 +- src/Networking/Common.hs | 2 +- src/Networking/Incoming.hs | 60 ++++++++++---------- src/Networking/NetworkingMethod/Fast.hs | 14 ++--- src/Networking/NetworkingMethod/Stateless.hs | 18 +++--- src/Networking/Outgoing.hs | 6 +- 7 files changed, 51 insertions(+), 52 deletions(-) delete mode 100644 TODO diff --git a/TODO b/TODO deleted file mode 100644 index d982499..0000000 --- a/TODO +++ /dev/null @@ -1 +0,0 @@ -Check if everything works when a connection is send to another partner and then gets recieved again. \ No newline at end of file diff --git a/src/Interpreter.hs b/src/Interpreter.hs index b5fb1fd..8e5520f 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -174,7 +174,7 @@ eval = \case (env, (sockets, vchanconnections, activeConnections)) <- ask socketsraw <- liftIO $ MVar.readMVar sockets let port = show $ head $ Map.keys socketsraw - val <- liftIO $ NI.recieveValue vchanconnections activeConnections ci port + val <- liftIO $ NI.receiveValue vchanconnections activeConnections ci port liftIO $ C.traceIO $ "Read " ++ show val ++ " from Chan, over expression " ++ show e -- Disable the old channel and get a new one diff --git a/src/Networking/Common.hs b/src/Networking/Common.hs index 1e78d31..ddab60b 100644 --- a/src/Networking/Common.hs +++ b/src/Networking/Common.hs @@ -23,7 +23,7 @@ createActiveConnections = NetMethod.createActiveConnections acceptConversations activeCons connectionhandler port socketsmvar = NetMethod.acceptConversations activeCons connectionhandler port socketsmvar -recieveResponse con waitTime tries = NetMethod.recieveResponse con waitTime tries +receiveResponse con waitTime tries = NetMethod.receiveResponse con waitTime tries endConversation con waitTime tries = NetMethod.endConversation con waitTime tries diff --git a/src/Networking/Incoming.hs b/src/Networking/Incoming.hs index c01344d..f9eabf1 100644 --- a/src/Networking/Incoming.hs +++ b/src/Networking/Incoming.hs @@ -30,13 +30,13 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria clientHostaddress <- case snd clientsocket of SockAddrInet _ hostname -> return $ hostaddressTypeToString hostname _ -> do - recievedNetLog message "Error during recieving a networkmessage: only ipv4 is currently supported!" + receivedNetLog message "Error during recieving a networkmessage: only ipv4 is currently supported!" return "" netcons <- MVar.readMVar mvar case Map.lookup userid netcons of Just ncToPartner -> do - recievedNetLog message $ "Recieved message as: " ++ ncOwnUserID ncToPartner ++ " (" ++ ownport ++ ") from: " ++ ncPartnerUserID ncToPartner + receivedNetLog message $ "Received message as: " ++ ncOwnUserID ncToPartner ++ " (" ++ ownport ++ ") from: " ++ ncPartnerUserID ncToPartner ncIsReady <- isReadyForUse ncToPartner if ncIsReady then do busy <- SSem.tryWait $ ncHandlingIncomingMessage ncToPartner @@ -45,8 +45,8 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria constate <- MVar.readMVar $ ncConnectionState ncToPartner reply <- case constate of RedirectRequest _ _ host port _ _ _ -> do - recievedNetLog message $ "Found redirect request for: " ++ userid - recievedNetLog message $ "Send redirect to:" ++ host ++ ":" ++ port + receivedNetLog message $ "Found redirect request for: " ++ userid + receivedNetLog message $ "Send redirect to:" ++ host ++ ":" ++ port SSem.signal $ ncHandlingIncomingMessage ncToPartner NC.sendResponse hdl (Messages.Redirect host port) Connected {} -> case deserialmessages of @@ -55,13 +55,13 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria let fixedPartnerHostAddress = setPartnerHostAddress clientHostaddress val success <- NB.writeIfNext (ncRead ncToPartner) count fixedPartnerHostAddress if success then do - recievedNetLog message "Inserting VChans into VChanCons" + receivedNetLog message "Inserting VChans into VChanCons" insertVChansIntoVChanCons mvar False fixedPartnerHostAddress - recievedNetLog message "Message written to Channel" - else recievedNetLog message "Message not correct" + receivedNetLog message "Message written to Channel" + else receivedNetLog message "Message not correct" SSem.signal $ ncHandlingIncomingMessage ncToPartner NC.sendResponse hdl Messages.Okay - recievedNetLog message "Sent okay" + receivedNetLog message "Sent okay" -- DC.unlockInterpreterReads (ncRead ncToPartner) RequestValue userid count -> do SSem.signal $ ncHandlingIncomingMessage ncToPartner @@ -75,14 +75,14 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria NB.updateAcknowledgements (NCon.ncWrite ncToPartner) count SSem.signal $ ncHandlingIncomingMessage ncToPartner NewPartnerAddress userid port connectionID -> do - recievedNetLog message $ "Trying to change the address to: " ++ clientHostaddress ++ ":" ++ port + receivedNetLog message $ "Trying to change the address to: " ++ clientHostaddress ++ ":" ++ port NCon.changePartnerAddress ncToPartner clientHostaddress port connectionID - recievedNetLog message $ "Successfully changed address to: " ++ clientHostaddress ++ ":" ++ port + receivedNetLog message $ "Successfully changed address to: " ++ clientHostaddress ++ ":" ++ port SSem.signal $ ncHandlingIncomingMessage ncToPartner NC.sendResponse hdl Messages.Okay successSendingResponse <- NO.sendNetworkMessage activeCons ncToPartner (Messages.AcknowledgePartnerAddress (ncOwnUserID ncToPartner) connectionID) $ -2 - when successSendingResponse $ recievedNetLog message "Successfully acknowledged message" + when successSendingResponse $ receivedNetLog message "Successfully acknowledged message" return () AcknowledgePartnerAddress userid connectionID -> do conConfirmed <- NCon.confirmConnectionID ncToPartner connectionID @@ -95,33 +95,33 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria return () _ -> do serial <- NSerialize.serialize deserialmessages - recievedNetLog message $ "Error unsupported networkmessage: "++ serial + receivedNetLog message $ "Error unsupported networkmessage: "++ serial SSem.signal $ ncHandlingIncomingMessage ncToPartner NC.sendResponse hdl Messages.Okay _ -> do - recievedNetLog message "Network Connection is in a illegal state!" + receivedNetLog message "Network Connection is in a illegal state!" SSem.signal $ ncHandlingIncomingMessage ncToPartner NC.sendResponse hdl Messages.Okay return reply Nothing -> do - recievedNetLog message "Message cannot be handled at the moment! Sending wait response" + receivedNetLog message "Message cannot be handled at the moment! Sending wait response" SSem.signal $ ncHandlingIncomingMessage ncToPartner NC.sendResponse hdl Messages.Wait else do - recievedNetLog message "Found a networkconnection, but it's not ready to be used yet" + receivedNetLog message "Found a networkconnection, but it's not ready to be used yet" NC.sendResponse hdl Messages.Wait Nothing -> do - recievedNetLog message "Recieved message from unknown connection" + receivedNetLog message "Received message from unknown connection" case deserialmessages of Introduce userid clientport synname syntype -> do serverid <- RandomID.newRandomID newpeer <- newNetworkConnection userid serverid clientHostaddress clientport userid serverid NC.sendResponse hdl (Messages.OkayIntroduce serverid) repserial <- NSerialize.serialize $ Messages.OkayIntroduce serverid - recievedNetLog message $ " Response to "++ userid ++ ": " ++ repserial + receivedNetLog message $ " Response to "++ userid ++ ": " ++ repserial - recievedNetLog message "Patching MVar" + receivedNetLog message "Patching MVar" netcons <- MVar.takeMVar mvar MVar.putMVar mvar $ Map.insert userid newpeer netcons @@ -132,15 +132,15 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria _ -> do serial <- NSerialize.serialize deserialmessages - recievedNetLog message $ "Error unsupported networkmessage: "++ serial - recievedNetLog message "This is probably a timing issue! Lets resend later" + receivedNetLog message $ "Error unsupported networkmessage: "++ serial + receivedNetLog message "This is probably a timing issue! Lets resend later" NC.sendResponse hdl Messages.Wait - recievedNetLog message "Message successfully handled" + receivedNetLog message "Message successfully handled" -recievedNetLog :: String -> String -> IO () -recievedNetLog msg info = Config.traceNetIO $ "Recieved message: "++msg++" \n Status: "++info +receivedNetLog :: String -> String -> IO () +receivedNetLog msg info = Config.traceNetIO $ "Received message: "++msg++" \n Status: "++info setPartnerHostAddress :: String -> Value -> Value setPartnerHostAddress address = modifyVChansStatic (handleSerial address) @@ -272,12 +272,12 @@ replaceVChanSerial activeCons mvar input = modifyVChans (handleSerial activeCons return $ VChan nc used _ -> return input -recieveValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value -recieveValue vchanconsvar activeCons networkconnection ownport = do - recieveValueInternal 0 vchanconsvar activeCons networkconnection ownport +receiveValue :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value +receiveValue vchanconsvar activeCons networkconnection ownport = do + receiveValueInternal 0 vchanconsvar activeCons networkconnection ownport where - recieveValueInternal :: Int -> VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value - recieveValueInternal count vchanconsvar activeCons networkconnection ownport = do + receiveValueInternal :: Int -> VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> String -> IO Value + receiveValueInternal count vchanconsvar activeCons networkconnection ownport = do let readDC = ncRead networkconnection mbyUnclean <- NB.tryTake readDC case mbyUnclean of @@ -295,10 +295,10 @@ recieveValue vchanconsvar activeCons networkconnection ownport = do case connectionState of Connected {} -> NO.sendNetworkMessage activeCons networkconnection (Messages.RequestValue (ncOwnUserID networkconnection) msgCount) $ -2 _ -> return True - recieveValueInternal 100 vchanconsvar activeCons networkconnection ownport + receiveValueInternal 100 vchanconsvar activeCons networkconnection ownport else do threadDelay 5000 - recieveValueInternal (count-1) vchanconsvar activeCons networkconnection ownport + receiveValueInternal (count-1) vchanconsvar activeCons networkconnection ownport waitTillAcknowledged :: VChanConnections -> NMC.ActiveConnections -> NetworkConnection Value -> Int -> IO () waitTillAcknowledged vcv ac nc vaToAck = do diff --git a/src/Networking/NetworkingMethod/Fast.hs b/src/Networking/NetworkingMethod/Fast.hs index 28911bb..19d8dbf 100644 --- a/src/Networking/NetworkingMethod/Fast.hs +++ b/src/Networking/NetworkingMethod/Fast.hs @@ -51,14 +51,14 @@ conversationHandlerChangeHandle handle chan mvar sem = do isClosed <- MVar.newEmptyMVar MVar.putMVar isClosed False forkIO $ whileNotMVar isClosed (do - Stateless.recieveMessageInternal handle VG.parseConversation (\_ -> return ()) (\mes des -> do + Stateless.receiveMessageInternal handle VG.parseConversation (\_ -> return ()) (\mes des -> do case des of ConversationMessage cid message -> Chan.writeChan chan (cid, (mes, message)) ConversationResponse cid response -> do mymap <- MVar.takeMVar mvar MVar.putMVar mvar $ Map.insert cid (mes, response) mymap ConversationCloseAll -> do - Config.traceNetIO $ "Recieved Message: " ++ mes + Config.traceNetIO $ "Received Message: " ++ mes MVar.takeMVar isClosed MVar.putMVar isClosed True forkIO $ catch (hClose $ fst handle) onException @@ -77,8 +77,8 @@ conversationHandlerChangeHandle handle chan mvar sem = do onException :: IOException -> IO () onException _ = return () -recieveResponse :: Conversation -> Int -> Int -> IO (Maybe Response) -recieveResponse conv waitTime tries = do +receiveResponse :: Conversation -> Int -> Int -> IO (Maybe Response) +receiveResponse conv waitTime tries = do responsesMap <- MVar.readMVar $ convRespMap conv case Map.lookup (convID conv) responsesMap of Just (messages, deserial) -> do @@ -86,10 +86,10 @@ recieveResponse conv waitTime tries = do Nothing -> do if tries /= 0 then do threadDelay waitTime - recieveResponse conv waitTime $ max (tries-1) (-1) else return Nothing + receiveResponse conv waitTime $ max (tries-1) (-1) else return Nothing -recieveNewMessage :: Connection -> IO (Conversation, String, Message) -recieveNewMessage connection@(handle, isClosed, chan, mvar, sem) = do +receiveNewMessage :: Connection -> IO (Conversation, String, Message) +receiveNewMessage connection@(handle, isClosed, chan, mvar, sem) = do (cid, (serial, deserial)) <- Chan.readChan chan return (Conversation cid handle mvar sem, serial, deserial) diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index 56ef83c..b722493 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -30,8 +30,8 @@ sendMessage conv@(handle, _) value = do sendResponse :: NSerialize.Serializable a => Conversation -> a -> IO () sendResponse = sendMessage -recieveMessageInternal :: Conversation -> VT.Alex t -> (String -> IO b) -> (String -> t -> IO b) -> IO b -recieveMessageInternal conv@(handle, _) grammar fallbackResponse messageHandler = do +receiveMessageInternal :: Conversation -> VT.Alex t -> (String -> IO b) -> (String -> t -> IO b) -> IO b +receiveMessageInternal conv@(handle, _) grammar fallbackResponse messageHandler = do waitWhileEOF conv message <- hGetLine handle case VT.runAlex message grammar of @@ -134,7 +134,7 @@ acceptConversations ac connectionhandler port socketsmvar vchanconnections = do acceptClient activeCons connectionhandler mvar clientlist clientsocket ownport = do hdl <- getHandleFromSocket $ fst clientsocket let conv = (hdl, clientsocket) - recieveMessageInternal conv VG.parseMessages (\_ -> return ()) $ connectionhandler activeCons mvar clientlist clientsocket conv ownport + receiveMessageInternal conv VG.parseMessages (\_ -> return ()) $ connectionhandler activeCons mvar clientlist clientsocket conv ownport hClose hdl getFromNetworkThread :: Maybe Conversation -> ThreadId -> MVar.MVar a -> Int -> Int -> IO (Maybe a) @@ -153,15 +153,15 @@ getFromNetworkThreadWithModification conv func threadid mvar waitTime currentTry killThread threadid return Nothing -recieveResponse :: Conversation -> Int -> Int -> IO (Maybe Response) -recieveResponse conv waitTime tries = do +receiveResponse :: Conversation -> Int -> Int -> IO (Maybe Response) +receiveResponse conv waitTime tries = do retVal <- MVar.newEmptyMVar - threadid <- forkIO $ recieveMessageInternal conv VG.parseResponses (\_ -> MVar.putMVar retVal Nothing) (\_ des -> MVar.putMVar retVal $ Just des) + threadid <- forkIO $ receiveMessageInternal conv VG.parseResponses (\_ -> MVar.putMVar retVal Nothing) (\_ des -> MVar.putMVar retVal $ Just des) getFromNetworkThreadWithModification (Just conv) id threadid retVal waitTime tries -recieveNewMessage :: Conversation -> IO (Conversation, String, Message) -recieveNewMessage conv = do - recieveMessageInternal conv VG.parseMessages (\_ -> recieveNewMessage conv) $ \s des -> return (conv, s, des) +receiveNewMessage :: Conversation -> IO (Conversation, String, Message) +receiveNewMessage conv = do + receiveMessageInternal conv VG.parseMessages (\_ -> receiveNewMessage conv) $ \s des -> return (conv, s, des) endConversation :: Conversation -> Int -> Int -> IO () diff --git a/src/Networking/Outgoing.hs b/src/Networking/Outgoing.hs index 5b8636c..3934df1 100644 --- a/src/Networking/Outgoing.hs +++ b/src/Networking/Outgoing.hs @@ -102,8 +102,8 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen sendingNetLog serializedMessage "Aquired connection" NC.sendMessage con message sendingNetLog serializedMessage "Sent message" - potentialResponse <- NC.recieveResponse con 10000 50 - sendingNetLog serializedMessage "Recieved response" + potentialResponse <- NC.receiveResponse con 10000 50 + sendingNetLog serializedMessage "Received response" NC.endConversation con 10000 10 sendingNetLog serializedMessage "Ended connection" return potentialResponse @@ -161,7 +161,7 @@ initialConnect activeCons mvar hostname port ownport syntype= do Just con -> do ownuserid <- RandomID.newRandomID NC.sendMessage con (Messages.Introduce ownuserid ownport (fst syntype) $ snd syntype) - mbyintroductionanswer <- NC.recieveResponse con 10000 (-1) + mbyintroductionanswer <- NC.receiveResponse con 10000 (-1) NC.endConversation con 10000 10 case mbyintroductionanswer of Just introduction -> case introduction of From 5910ee3b3f54ea5b98ca72af3f2a715ca7f5f733 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 9 Mar 2023 17:33:22 +0100 Subject: [PATCH 206/229] Receiving is now also spelled correctly --- src/Networking/Incoming.hs | 2 +- src/Networking/NetworkingMethod/Stateless.hs | 2 +- src/Networking/Outgoing.hs | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Networking/Incoming.hs b/src/Networking/Incoming.hs index f9eabf1..7a472ca 100644 --- a/src/Networking/Incoming.hs +++ b/src/Networking/Incoming.hs @@ -30,7 +30,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria clientHostaddress <- case snd clientsocket of SockAddrInet _ hostname -> return $ hostaddressTypeToString hostname _ -> do - receivedNetLog message "Error during recieving a networkmessage: only ipv4 is currently supported!" + receivedNetLog message "Error during receiving a networkmessage: only ipv4 is currently supported!" return "" netcons <- MVar.readMVar mvar diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index b722493..7f5f80a 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -36,7 +36,7 @@ receiveMessageInternal conv@(handle, _) grammar fallbackResponse messageHandler message <- hGetLine handle case VT.runAlex message grammar of Left err -> do - Config.traceNetIO $ "Error during recieving a networkmessage: "++err++" Malformed message: " ++ message + Config.traceNetIO $ "Error during receiving a networkmessage: "++err++" Malformed message: " ++ message fallbackResponse message Right deserialmessage -> do messageHandler message deserialmessage diff --git a/src/Networking/Outgoing.hs b/src/Networking/Outgoing.hs index 3934df1..dad8e32 100644 --- a/src/Networking/Outgoing.hs +++ b/src/Networking/Outgoing.hs @@ -131,7 +131,7 @@ tryToSendNetworkMessage activeCons networkconnection hostname port message resen return False Nothing -> do - sendingNetLog serializedMessage "Error when recieving response" + sendingNetLog serializedMessage "Error when receiving response" if resendOnError /= 0 && resendOnError < (-2) then do connectionState <- MVar.readMVar $ ncConnectionState networkconnection case connectionState of From 4f2c51c7cd0620bd95723c97abe8732a2069bec1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Fri, 10 Mar 2023 14:18:29 +0100 Subject: [PATCH 207/229] New serialization routine --- src/Networking/Incoming.hs | 8 +- src/Networking/NetworkingMethod/Stateless.hs | 4 +- src/Networking/Outgoing.hs | 6 +- src/Networking/Serialize.hs | 291 ++++++++----------- src/PrettySyntax.hs | 1 - src/Syntax.hs | 4 - src/TCTyping.hs | 1 - src/ValueParsing/ValueGrammar.y | 2 +- test/SerializeSpec.hs | 43 +++ test/Utils.hs | 33 ++- 10 files changed, 207 insertions(+), 186 deletions(-) create mode 100644 test/SerializeSpec.hs diff --git a/src/Networking/Incoming.hs b/src/Networking/Incoming.hs index 7a472ca..6612686 100644 --- a/src/Networking/Incoming.hs +++ b/src/Networking/Incoming.hs @@ -94,8 +94,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria SSem.signal $ ncHandlingIncomingMessage ncToPartner return () _ -> do - serial <- NSerialize.serialize deserialmessages - receivedNetLog message $ "Error unsupported networkmessage: "++ serial + receivedNetLog message $ "Error unsupported networkmessage: "++ NSerialize.serialize deserialmessages SSem.signal $ ncHandlingIncomingMessage ncToPartner NC.sendResponse hdl Messages.Okay _ -> do @@ -118,7 +117,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria serverid <- RandomID.newRandomID newpeer <- newNetworkConnection userid serverid clientHostaddress clientport userid serverid NC.sendResponse hdl (Messages.OkayIntroduce serverid) - repserial <- NSerialize.serialize $ Messages.OkayIntroduce serverid + let repserial = NSerialize.serialize $ Messages.OkayIntroduce serverid receivedNetLog message $ " Response to "++ userid ++ ": " ++ repserial receivedNetLog message "Patching MVar" @@ -131,8 +130,7 @@ handleClient activeCons mvar clientlist clientsocket hdl ownport message deseria -- We must not write clients into the clientlist before adding them to the networkconnectionmap _ -> do - serial <- NSerialize.serialize deserialmessages - receivedNetLog message $ "Error unsupported networkmessage: "++ serial + receivedNetLog message $ "Error unsupported networkmessage: " ++ NSerialize.serialize deserialmessages receivedNetLog message "This is probably a timing issue! Lets resend later" NC.sendResponse hdl Messages.Wait diff --git a/src/Networking/NetworkingMethod/Stateless.hs b/src/Networking/NetworkingMethod/Stateless.hs index 7f5f80a..d25b4f9 100644 --- a/src/Networking/NetworkingMethod/Stateless.hs +++ b/src/Networking/NetworkingMethod/Stateless.hs @@ -23,9 +23,7 @@ type ConnectionHandler = ActiveConnectionsStateless -> MVar.MVar (Map.Map String type Conversation = ConversationStateless sendMessage :: NSerialize.Serializable a => Conversation -> a -> IO () -sendMessage conv@(handle, _) value = do - serializedValue <- NSerialize.serialize value - hPutStrLn handle (serializedValue ++" ") +sendMessage conv@(handle, _) value = hPutStrLn handle (NSerialize.serialize value ++" ") sendResponse :: NSerialize.Serializable a => Conversation -> a -> IO () sendResponse = sendMessage diff --git a/src/Networking/Outgoing.hs b/src/Networking/Outgoing.hs index dad8e32..4c04562 100644 --- a/src/Networking/Outgoing.hs +++ b/src/Networking/Outgoing.hs @@ -93,7 +93,7 @@ sendNetworkMessage activeCons networkconnection message resendOnError = do -- For numbers n smaller than -2 it will wait for abs(n)-2 times tryToSendNetworkMessage :: NMC.ActiveConnections -> NetworkConnection Value -> String -> String -> Message -> Int -> IO Bool tryToSendNetworkMessage activeCons networkconnection hostname port message resendOnError = do - serializedMessage <- NSerialize.serialize message + let serializedMessage = NSerialize.serialize message sendingNetLog serializedMessage $ "Sending message as: " ++ ncOwnUserID networkconnection ++ " to: " ++ ncPartnerUserID networkconnection ++ " Over: " ++ hostname ++ ":" ++ port mbycon <- NC.startConversation activeCons hostname port 10000 10 @@ -166,7 +166,7 @@ initialConnect activeCons mvar hostname port ownport syntype= do case mbyintroductionanswer of Just introduction -> case introduction of OkayIntroduce introductionanswer -> do - msgserial <- NSerialize.serialize $ Messages.Introduce ownuserid ownport (fst syntype) $ snd syntype + let msgserial = NSerialize.serialize $ Messages.Introduce ownuserid ownport (fst syntype) $ snd syntype Config.traceNetIO $ "Sending message as: " ++ ownuserid ++ " to: " ++ introductionanswer Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port Config.traceNetIO $ " Message: " ++ msgserial @@ -179,7 +179,7 @@ initialConnect activeCons mvar hostname port ownport syntype= do return $ VChan newConnection used _ -> do - introductionserial <- NSerialize.serialize introduction + let introductionserial = NSerialize.serialize introduction Config.traceNetIO $ "Illegal answer from server: " ++ introductionserial threadDelay 1000000 initialConnect activeCons mvar hostname port ownport syntype diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index a27d006..05ed5a9 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -10,7 +10,6 @@ import Kinds import Networking.Messages import ProcessEnvironmentTypes import Syntax -import qualified Networking.NetworkConnection as NCon newtype SerializationException = UnserializableException String deriving Eq @@ -23,208 +22,180 @@ instance Exception SerializationException class Serializable a where - serialize :: a -> IO String + serialize :: a -> String +class SerializableList b where + toSer :: String -> b + +instance SerializableList String where + toSer = id + +instance (SerializableList b, Serializable a) => SerializableList (a -> b) where + toSer serList serElem = toSer $ serList ++ "(" ++ serialize serElem ++ ")" + +merge :: (SerializableList b) => b +merge = toSer "" + +serializeArgs :: (SerializableList b) => b +serializeArgs = toSer "" instance Serializable ConversationSession where serialize = \case - ConversationMessage c m -> serializeLabeledEntryMulti "NConversationMessage" c $ sLast m - ConversationResponse c r -> serializeLabeledEntryMulti "NConversationResponse" c $ sLast r - ConversationCloseAll -> return "NConversationCloseAll" + ConversationMessage c m -> "NConversationMessage" ++ serializeArgs c m + ConversationResponse c r -> "NConversationResponse" ++ serializeArgs c r + ConversationCloseAll -> "NConversationCloseAll" instance Serializable Response where serialize = \case - Redirect host port -> serializeLabeledEntryMulti "NRedirect" host $ sLast port - Okay -> return "NOkay" - OkayIntroduce u -> serializeLabeledEntry "NOkayIntroduce" u - Wait -> return "NWait" - Error -> return "NError" + Redirect host port -> "NRedirect" ++ serializeArgs host port + Okay -> "NOkay" + OkayIntroduce u -> "NOkayIntroduce" ++ serializeArgs u + Wait -> "NWait" + Error -> "NError" instance Serializable Message where serialize = \case - Introduce p port tn t -> serializeLabeledEntryMulti "NIntroduce" p $ sNext port $ sNext tn $ sLast t - NewValue p c v -> serializeLabeledEntryMulti "NNewValue" p $ sNext c $ sLast v - RequestValue p c -> serializeLabeledEntryMulti "NRequestValue" p $ sLast c - AcknowledgeValue p c -> serializeLabeledEntryMulti "NAcknowledgeValue" p $ sLast c - NewPartnerAddress p port conID -> serializeLabeledEntryMulti "NNewPartnerAddress" p $ sNext port $ sLast conID - AcknowledgePartnerAddress p conID -> serializeLabeledEntryMulti "NAcknowledgePartnerAddress" p $ sLast conID - Disconnect p -> serializeLabeledEntry "NDisconnect" p - AcknowledgeDisconnect p -> serializeLabeledEntry "NAcknowledgeDisconnect" p - -instance Serializable NCon.ConnectionState where - serialize = \case - NCon.Connected hostname port partnerConnectionID _ _ -> serializeLabeledEntryMulti "SConnected" hostname $ sNext port $ sLast partnerConnectionID - _ -> throw $ UnserializableException "VChan can only be serialized when in Connected mode" + Introduce p port tn t -> "NIntroduce" ++ serializeArgs p port tn t + NewValue p c v -> "NNewValue" ++ serializeArgs p c v + RequestValue p c -> "NRequestValue" ++ serializeArgs p c + AcknowledgeValue p c -> "NAcknowledgeValue" ++ serializeArgs p c + NewPartnerAddress p port conID -> "NNewPartnerAddress" ++ serializeArgs p port conID + AcknowledgePartnerAddress p conID -> "NAcknowledgePartnerAddress" ++ serializeArgs p conID + Disconnect p -> "NDisconnect" ++ serializeArgs p + AcknowledgeDisconnect p -> "NAcknowledgeDisconnect" ++ serializeArgs p instance Serializable Value where serialize = \case - VUnit -> return "VUnit" - VLabel s -> serializeLabeledEntry "VLabel" s - VInt i -> serializeLabeledEntry "VInt" i - VDouble d -> serializeLabeledEntry "VDouble" d - VString s -> serializeLabeledEntry "VString" s - VSend v -> serializeLabeledEntry "VSend" v - VPair a b -> serializeLabeledEntryMulti "VPair" a $ sLast b - VType t -> serializeLabeledEntry "VType" t - VFunc env s exp -> serializeLabeledEntryMulti "VFunc" env $ sNext s $ sLast exp - VDynCast v t -> serializeLabeledEntryMulti "VDynCast" v $ sLast t - VFuncCast v ft1 ft2 -> serializeLabeledEntryMulti "VFuncCast" v $ sNext ft1 $ sLast ft2 - VRec env f x e0 e1 -> serializeLabeledEntryMulti "VRec" env $ sNext f $ sNext x $ sNext e0 $ sLast e1 - VNewNatRec env f n tid ty ez x es -> serializeLabeledEntryMulti "VNewNatRec" env $ sNext f $ sNext n $ sNext tid $ sNext ty $ sNext ez $ sNext x $ sLast es + VUnit -> "VUnit" + VLabel s -> "VLabel" ++ serializeArgs s + VInt i -> "VInt" ++ serializeArgs i + VDouble d -> "VDouble" ++ serializeArgs d + VString s -> "VString" ++ serializeArgs s + VSend v -> "VSend" ++ serializeArgs v + VPair a b -> "VPair" ++ serializeArgs a b + VType t -> "VType" ++ serializeArgs t + VFunc env s exp -> "VFunc" ++ serializeArgs env s exp + VDynCast v t -> "VDynCast" ++ serializeArgs v t + VFuncCast v ft1 ft2 -> "VFuncCast" ++ serializeArgs v ft1 ft2 + VRec env f x e0 e1 -> "VRec" ++ serializeArgs env f x e0 e1 + VNewNatRec env f n tid ty ez x es -> "VNewNatRec" ++ serializeArgs env f n tid ty ez x es VChan {} -> throw $ UnserializableException "VChan" - VChanSerial r w p o c -> serializeLabeledEntryMulti "VChanSerial" r $ sNext w $ sNext p $ sNext o $ sLast c + VChanSerial r w p o c -> "VChanSerial" ++ serializeArgs r w p o c instance Serializable Multiplicity where serialize = \case - MMany -> return "MMany" - MOne -> return "MOne" + MMany -> "MMany" + MOne -> "MOne" instance Serializable Type where serialize = \case - TUnit -> return "TUnit" - TInt -> return "TInt" - TDouble -> return "TDouble" - TBot -> return "TBot" - TDyn -> return "TDyn" - TNat -> return "TNat" - TString -> return "TString" - TNatLeq i -> serializeLabeledEntry "TNatLeq" i - TNatRec e t1 ident t2 -> serializeLabeledEntryMulti "TNatRec" e $ sNext t1 $ sNext ident $ sLast t2 - TVar b ident -> serializeLabeledEntryMulti "TVar" b $ sLast ident - TAbs ident t1 t2 -> serializeLabeledEntryMulti "TAbs" ident $ sNext t1 $ sLast t2 - TName b ident -> serializeLabeledEntryMulti "TName" b $ sLast ident - TLab arr -> serializeLabeledEntry "TLab" arr - TFun mult ident t1 t2 -> serializeLabeledEntryMulti "TFun" mult $ sNext ident $ sNext t1 $ sLast t2 - TPair ident t1 t2 -> serializeLabeledEntryMulti "TPair" ident $ sNext t1 $ sLast t2 - TSend ident t1 t2 -> serializeLabeledEntryMulti "TSend" ident $ sNext t1 $ sLast t2 - TRecv ident t1 t2 -> serializeLabeledEntryMulti "TRecv" ident $ sNext t1 $ sLast t2 - TCase e arr -> serializeLabeledEntryMulti "TCase" e $ sLast arr - TEqn e1 e2 t -> serializeLabeledEntryMulti "TEqn" e1 $ sNext e2 $ sLast t - TSingle ident -> serializeLabeledEntry "TSingle" ident - - TServerSocket -> return "TServerSocket" + TUnit -> "TUnit" + TInt -> "TInt" + TDouble -> "TDouble" + TBot -> "TBot" + TDyn -> "TDyn" + TNat -> "TNat" + TString -> "TString" + TNatLeq i -> "TNatLeq" ++ serializeArgs i + TNatRec e t1 ident t2 -> "TNatRec" ++ serializeArgs e t1 ident t2 + TVar b ident -> "TVar" ++ serializeArgs b ident + TAbs ident t1 t2 -> "TAbs" ++ serializeArgs ident t1 t2 + TName b ident -> "TName" ++ serializeArgs b ident + TLab arr -> "TLab" ++ serializeArgs arr + TFun mult ident t1 t2 -> "TFun" ++ serializeArgs mult ident t1 t2 + TPair ident t1 t2 -> "TPair" ++ serializeArgs ident t1 t2 + TSend ident t1 t2 -> "TSend" ++ serializeArgs ident t1 t2 + TRecv ident t1 t2 -> "TRecv" ++ serializeArgs ident t1 t2 + TCase e arr -> "TCase" ++ serializeArgs e arr + TEqn e1 e2 t -> "TEqn" ++ serializeArgs e1 e2 t + TSingle ident -> "TSingle" ++ serializeArgs ident instance Serializable Exp where serialize = \case - Let ident e1 e2 -> serializeLabeledEntryMulti "ELet" ident $ sNext e1 $ sLast e2 - Math mathop -> serializeLabeledEntry "EMath" mathop - Lit l -> serializeLabeledEntry "ELit" l - Succ e -> serializeLabeledEntry "ESucc" e - NatRec e1 e2 ident1 ident2 ident3 t e3 -> serializeLabeledEntryMulti "NatRec" e1 $ sNext e2 $ sNext ident1 $ sNext ident2 $ sNext ident3 $ sNext t $ sLast e3 - NewNatRec ident1 ident2 ident3 t e1 ident4 e2 -> serializeLabeledEntryMulti "ENewNatRec" ident1 $ sNext ident2 $ sNext ident3 $ sNext t $ sNext e1 $ sNext ident4 $ sLast e2 - Var ident -> serializeLabeledEntry "EVar" ident - Lam mult ident t e -> serializeLabeledEntryMulti "ELam" mult $ sNext ident $ sNext t $ sLast e - Rec ident1 ident2 e1 e2 -> serializeLabeledEntryMulti "ERec" ident1 $ sNext ident2 $ sNext e1 $ sLast e2 - App e1 e2 -> serializeLabeledEntryMulti "EApp" e1 $ sLast e2 - Pair mult ident e1 e2 -> serializeLabeledEntryMulti "EPair" mult $ sNext ident $ sNext e1 $ sLast e2 - LetPair ident1 ident2 e1 e2 -> serializeLabeledEntryMulti "ELetPair" ident1 $ sNext ident2 $ sNext e1 $ sLast e2 - Fst e -> serializeLabeledEntry "EFst" e - Snd e -> serializeLabeledEntry "ESnd" e - Fork e -> serializeLabeledEntry "EFork" e - New t -> serializeLabeledEntry "ENew" t - Send e -> serializeLabeledEntry "ESend" e - Recv e -> serializeLabeledEntry "ERecv" e - Case e arr -> serializeLabeledEntryMulti "ECase" e $ sLast arr - Cast e t1 t2 -> serializeLabeledEntryMulti "ECast" e $ sNext t1 $ sLast t2 - - Connect e0 t e1 e2 -> serializeLabeledEntryMulti "EConnect" e0 $ sNext t $ sNext e1 $ sLast e2 - Accept e t -> serializeLabeledEntryMulti "EAccept" e $ sLast t + Let ident e1 e2 -> "ELet" ++ serializeArgs ident e1 e2 + Math mathop -> "EMath" ++ serializeArgs mathop + Lit l -> "ELit" ++ serializeArgs l + Succ e -> "ESucc" ++ serializeArgs e + NatRec e1 e2 ident1 ident2 ident3 t e3 -> "NatRec" ++ serializeArgs e1 e2 ident1 ident2 ident3 t e3 + NewNatRec ident1 ident2 ident3 t e1 ident4 e2 -> "ENewNatRec" ++ serializeArgs ident1 ident2 ident3 t e1 ident4 e2 + Var ident -> "EVar" ++ serializeArgs ident + Lam mult ident t e -> "ELam" ++ serializeArgs mult ident t e + Rec ident1 ident2 e1 e2 -> "ERec" ++ serializeArgs ident1 ident2 e1 e2 + App e1 e2 -> "EApp" ++ serializeArgs e1 e2 + Pair mult ident e1 e2 -> "EPair" ++ serializeArgs mult ident e1 e2 + LetPair ident1 ident2 e1 e2 -> "ELetPair" ++ serializeArgs ident1 ident2 e1 e2 + Fst e -> "EFst" ++ serializeArgs e + Snd e -> "ESnd" ++ serializeArgs e + Fork e -> "EFork" ++ serializeArgs e + New t -> "ENew" ++ serializeArgs t + Send e -> "ESend" ++ serializeArgs e + Recv e -> "ERecv" ++ serializeArgs e + Case e arr -> "ECase" ++ serializeArgs e arr + Cast e t1 t2 -> "ECast" ++ serializeArgs e t1 t2 + + Connect e0 t e1 e2 -> "EConnect" ++ serializeArgs e0 t e1 e2 + Accept e t -> "EAccept" ++ serializeArgs e t instance Serializable (MathOp Exp) where serialize = \case - Add e1 e2 -> serializeLabeledEntryMulti "MAdd" e1 $ sLast e2 - Sub e1 e2 -> serializeLabeledEntryMulti "MSub" e1 $ sLast e2 - Mul e1 e2 -> serializeLabeledEntryMulti "MMul" e1 $ sLast e2 - Div e1 e2 -> serializeLabeledEntryMulti "MDiv" e1 $ sLast e2 - Neg e -> serializeLabeledEntry "MNeg" e + Add e1 e2 -> "MAdd" ++ serializeArgs e1 e2 + Sub e1 e2 -> "MSub" ++ serializeArgs e1 e2 + Mul e1 e2 -> "MMul" ++ serializeArgs e1 e2 + Div e1 e2 -> "MDiv" ++ serializeArgs e1 e2 + Neg e -> "MNeg" ++ serializeArgs e instance Serializable Literal where serialize = \case - LInt i -> serializeLabeledEntry "LInt" i - LNat i -> serializeLabeledEntry "LNat" i - LDouble d -> serializeLabeledEntry "LDouble" d - LLab s -> serializeLabeledEntry "LLab" s - LUnit -> return "LUnit" - LString s -> serializeLabeledEntry "LString" s + LInt i -> "LInt" ++ serializeArgs i + LNat i -> "LNat" ++ serializeArgs i + LDouble d -> "LDouble" ++ serializeArgs d + LLab s -> "LLab" ++ serializeArgs s + LUnit -> "LUnit" + LString s -> "LString" ++ serializeArgs s instance Serializable FuncType where - serialize (FuncType env s t1 t2) = serializeLabeledEntryMulti "SFuncType" env $ sNext s $ sNext t1 $ sLast t2 + serialize (FuncType env s t1 t2) = "SFuncType" ++ serializeArgs env s t1 t2 instance Serializable GType where serialize = \case - GUnit -> return "GUnit" - GLabel lt -> serializeLabeledEntry "GLabel" lt - GFunc mult -> serializeLabeledEntry "GFunc" mult - GPair -> return "GPair" - GNat -> return "GNat" - GNatLeq i -> serializeLabeledEntry "GNatLeq" i - GInt -> return "GInt" - GDouble -> return "GDouble" - GString -> return "GString" - -sLast :: Serializable a => a -> IO String -sLast x = sNext x $ return "" - -sNext :: Serializable a => a -> IO String -> IO String -sNext x ios = do - xString <- serialize x - iosString <- ios - return $ " (" ++ xString ++ ")" ++ iosString - -serializeLabeledEntryMulti :: Serializable a => String -> a -> IO String -> IO String -serializeLabeledEntryMulti label x ios = do - xString <- serialize x - iosString <- ios - return $ label ++ " (" ++ xString ++ ")" ++ iosString - -serializeLabeledEntry :: Serializable a => String -> a -> IO String -serializeLabeledEntry label x = do - xString <- serialize x - return $ label ++ " (" ++ xString ++ ")" + GUnit -> "GUnit" + GLabel lt -> "GLabel" ++ serializeArgs lt + GFunc mult -> "GFunc" ++ serializeArgs mult + GPair -> "GPair" + GNat -> "GNat" + GNatLeq i -> "GNatLeq" ++ serializeArgs i + GInt -> "GInt" + GDouble -> "GDouble" + GString -> "GString" instance {-# OVERLAPPING #-} Serializable String where - serialize s = return $ "String:"++ show s + serialize s = "String:"++ show s instance Serializable Int where - serialize i = return $ "Int:" ++ show i + serialize i = "Int:" ++ show i instance Serializable Integer where - serialize i = return $ "Integer:" ++ show i + serialize i = "Integer:" ++ show i instance Serializable Bool where - serialize b = return $ "Bool:" ++ show b + serialize b = "Bool:" ++ show b instance Serializable Double where - serialize d = return $ "Double:" ++ show d + serialize d = "Double:" ++ show d instance ((Serializable a, Serializable b) => Serializable (a, b)) where - serialize (s, t) = do - ss <- serialize s - ts <- serialize t - return $ "((" ++ ss ++ ") (" ++ ts ++ "))" + serialize (s, t) = "((" ++ serialize s++ ") (" ++ serialize t ++ "))" instance ((Serializable a, Serializable b, Serializable c) => Serializable (a, b, c)) where - serialize (s, t, u) = do - ss <- serialize s - ts <- serialize t - us <- serialize u - return $ "((" ++ ss ++ ") (" ++ ts ++ ") (" ++ us ++ "))" + serialize (s, t, u) = "((" ++ serialize s ++ ") (" ++ serialize t ++ ") (" ++ serialize u ++ "))" instance ((Serializable a, Serializable b, Serializable c, Serializable d) => Serializable (a, b, c, d)) where - serialize (s, t, u, v) = do - ss <- serialize s - ts <- serialize t - us <- serialize u - vs <- serialize v - return $ "((" ++ ss ++ ") (" ++ ts ++ ") (" ++ us ++ ") (" ++ vs ++ "))" + serialize (s, t, u, v) = "((" ++ serialize s ++ ") (" ++ serialize t ++ ") (" ++ serialize u ++ ") (" ++ serialize v ++ "))" instance {-# OVERLAPPING #-} Serializable PEnv where serialize arr = serializeLabeledArray "PEnv" arr instance {-# OVERLAPPING #-} Serializable PEnvEntry where - serialize (s, t) = do - ss <- serialize s - ts <- serialize t - return $ "PEnvEntry (" ++ ss ++ ") (" ++ ts ++ ")" + serialize (s, t) = "PEnvEntry (" ++ serialize s ++ ") (" ++ serialize t ++ ")" instance {-# OVERLAPPING #-} Serializable LabelType where serialize as = serializeLabeledArray "SLabelType" (elems as) @@ -241,22 +212,10 @@ instance {-# OVERLAPPING #-} Serializable [String] where instance {-# OVERLAPPING #-}Serializable [Value] where serialize arr = serializeLabeledArray "SValuesArray" arr +serializeLabeledArray :: Serializable a => String -> [a] -> String +serializeLabeledArray label arr = label ++ " [" ++ serializeElements arr ++ "]" - -instance Serializable (Chan.Chan Value) where - serialize c = do - ccnt <- getChanContents c - serialize ccnt - -serializeLabeledArray :: Serializable a => String -> [a] -> IO String -serializeLabeledArray label arr = do - elems <- serializeElements arr - return $ label ++ " [" ++ elems ++ "]" - -serializeElements :: Serializable a => [a] -> IO String -serializeElements [] = return "" +serializeElements :: Serializable a => [a] -> String +serializeElements [] = "" serializeElements [x] = serialize x -serializeElements (x:xs) = do - h <- serialize x - t <- serializeElements xs - return $ h ++ ", " ++ t \ No newline at end of file +serializeElements (x:xs) = serialize x ++ ", " ++ serializeElements xs diff --git a/src/PrettySyntax.hs b/src/PrettySyntax.hs index c33b086..fad7b54 100644 --- a/src/PrettySyntax.hs +++ b/src/PrettySyntax.hs @@ -60,7 +60,6 @@ instance Pretty Type where pretty TDyn = pretty "★" pretty TDouble = pretty "Double" pretty TString = pretty "String" - pretty TServerSocket = pretty "ServerSocket" -- the bool indicates whether the type needs to be dualized pretty (TName b s) = (if b then pretty "~" else mempty) <> pretty s pretty (TVar b s) = (if b then pretty "~" else mempty) <> brackets (pretty s) diff --git a/src/Syntax.hs b/src/Syntax.hs index 94c71fe..2a8d6ef 100644 --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -75,7 +75,6 @@ data Type | TCase Exp [(String, Type)] | TEqn Exp Exp Type | TSingle Ident -- same value (and type) as ident - | TServerSocket deriving (Show) dualof :: Type -> Type @@ -201,7 +200,6 @@ instance Freevars Type where fv (TNatLeq _) = Set.empty fv (TNatRec e tz y ts) = fv e <> fv tz <> Set.delete y (fv ts) fv (TAbs x ty1 ty2) = fv ty1 <> Set.delete x (fv ty2) - fv TServerSocket = Set.empty instance Freevars TypeSegment where fv ts = fv (segTy ts) @@ -352,7 +350,6 @@ single x tyx ty = TNatRec e (single x tyx tz) y (if x==y then ts else single x tyx ts) TAbs y t1 t2 -> TAbs y (single x tyx t1) (if x==y then t2 else single x tyx t2) - TServerSocket -> TServerSocket varsupply :: Ident -> [Ident] @@ -444,4 +441,3 @@ tsubst tn tyn ty = ts ty TSingle x -> ty TUnit -> TUnit TAbs _ _ _ -> ty - TServerSocket -> TServerSocket diff --git a/src/TCTyping.hs b/src/TCTyping.hs index 9c4e62e..379f7c8 100644 --- a/src/TCTyping.hs +++ b/src/TCTyping.hs @@ -70,7 +70,6 @@ kiSynth te (TVar b v) = do kentry <- TC.kindLookup v let k = keKind kentry return (k, mult k) -kiSynth te TServerSocket = return (Kun, MMany) kiSynth te ty = TC.mfail ("kiSynth fails on " ++ pshow ty) diff --git a/src/ValueParsing/ValueGrammar.y b/src/ValueParsing/ValueGrammar.y index 021eaa2..f2a3895 100644 --- a/src/ValueParsing/ValueGrammar.y +++ b/src/ValueParsing/ValueGrammar.y @@ -340,7 +340,7 @@ SValuesElements : Value ',' SValuesElements {$1 : $3} | Value {[$1]} | {- empty -} {[]} -LabelType : slabeltype '{' SStringElements '}' {$3} +LabelType : slabeltype '[' SStringElements ']' {$3} SArrayIntElement : '(' '(' SValuesArray ')' '(' int ')' '(' int ')' ')' {($3, $6, $9)} diff --git a/test/SerializeSpec.hs b/test/SerializeSpec.hs new file mode 100644 index 0000000..88f34df --- /dev/null +++ b/test/SerializeSpec.hs @@ -0,0 +1,43 @@ +module SerializeSpec (spec) where + +import Networking.Messages +import Syntax +import Test.Hspec +import ProcessEnvironmentTypes +import qualified Data.Set as Set + +import Utils + +spec :: Spec +spec = do + describe "Serialize Values" $ do + it "VUnit" $ serializesConsistentlyValue VUnit + it "VLabel" $ serializesConsistentlyValue $ VLabel "MyLabel" + it "VInt" $ serializesConsistentlyValue $ VInt 42 + it "VDouble" $ serializesConsistentlyValue $ VDouble 42.1337 + it "VString" $ serializesConsistentlyValue $ VString "Hello World" + it "VSend" $ serializesConsistentlyValue $ VSend $ VString "Hello World" + it "VPair" $ serializesConsistentlyValue $ VPair (VInt 1337) (VLabel "var") + it "VType" $ serializesConsistentlyValue $ VType $ TNatLeq 42 + it "VFunc" $ serializesConsistentlyValue $ VFunc [("s1", VString "String1"), ("i1", VInt 32)] "VFuncString" (Math (Add (Var "v1") (Lit (LInt 42)))) + it "VDynCast" $ serializesConsistentlyValue $ VDynCast VUnit (GLabel (Set.fromList ["String1", "String2"])) + it "VFuncCast" $ serializesConsistentlyValue $ VFuncCast (VInt 42) (FuncType [("s1", VString "String1"), ("i1", VInt 32)] "FuncTypeString" TUnit TInt) (FuncType [("s2", VString "String2"), ("i2", VInt 42)] "FuncTypeString2" TInt (TVar False "Ident1")) + it "VChanSerial" $ serializesConsistentlyValue $ VChanSerial ([VInt 42], 2, 3) ([], 0, 0) "partnerID" "ownID" ("127.0.0.1", "4242", "conversationID") + describe "Serialize Messages" $ do + it "Introduce" $ serializesConsistentlyMessage $ Introduce "userID" "4242" (TName False "TestName") (TSend "#!" TInt (TRecv "#?" TString TUnit)) + it "NewValue" $ serializesConsistentlyMessage $ NewValue "userID" 2 $ VInt 42 + it "RequestValue" $ serializesConsistentlyMessage $ RequestValue "userID" 42 + it "AcknowledgeValue" $ serializesConsistentlyMessage $ AcknowledgeValue "userID" 42 + it "NewPartnerAddress" $ serializesConsistentlyMessage $ NewPartnerAddress "userID" "4200" "conID1337" + it "AcknowledgePartnerAddress" $ serializesConsistentlyMessage $ AcknowledgePartnerAddress "partnerID" "conID1337" + it "Disconnect" $ serializesConsistentlyMessage $ Disconnect "ownID" + describe "Serialize Responses" $ do + it "Redirect" $ serializesConsistentlyResponse $ Redirect "42.0.0.1" "1337" + it "Okay" $ serializesConsistentlyResponse Okay + it "OkayIntroduce" $ serializesConsistentlyResponse $ OkayIntroduce "ownID" + it "Wait" $ serializesConsistentlyResponse Wait + it "Error" $ serializesConsistentlyResponse Error + describe "Serialize ConversationSession" $ do + it "ConversationMessage" $ serializesConsistentlyConversation $ ConversationMessage "conv42" $ NewValue "userID" 2 $ VInt 42 + it "ConversationResponse" $ serializesConsistentlyConversation $ ConversationResponse "conv42" Okay + it "ConversationCloseAll" $ serializesConsistentlyConversation ConversationCloseAll \ No newline at end of file diff --git a/test/Utils.hs b/test/Utils.hs index c2d795a..9e49ded 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -5,9 +5,10 @@ import Syntax import Interpreter import ProcessEnvironment import ProcessEnvironmentTypes --- import qualified Networking.NetworkingMethod.NetworkingMethodCommon as NMC --- import qualified Networking.NetworkingMethod.Stateless as Stateless import qualified Networking.Common as NC +import qualified Networking.Serialize as NSer +import qualified ValueParsing.ValueGrammar as VG +import qualified ValueParsing.ValueTokens as VT import Control.Monad.Reader (runReaderT) import Test.Hspec import Control.Concurrent.MVar @@ -55,3 +56,31 @@ shouldInterpretTypeTo t expected = do handles <- NC.createActiveConnections nft <- runReaderT (evalType t) ([], (sockets, vchanconnections, handles)) nft `shouldBe` expected + +serializesConsistentlyValue :: NSer.Serializable a => a -> Expectation +serializesConsistentlyValue serializable = + let serial = NSer.serialize serializable in + case VT.runAlex serial VG.parseValues of + Left err -> err `shouldBe` serial + Right deserial -> NSer.serialize deserial `shouldBe` serial + +serializesConsistentlyMessage :: NSer.Serializable a => a -> Expectation +serializesConsistentlyMessage serializable = + let serial = NSer.serialize serializable in + case VT.runAlex serial VG.parseMessages of + Left err -> err `shouldBe` serial + Right deserial -> NSer.serialize deserial `shouldBe` serial + +serializesConsistentlyResponse :: NSer.Serializable a => a -> Expectation +serializesConsistentlyResponse serializable = + let serial = NSer.serialize serializable in + case VT.runAlex serial VG.parseResponses of + Left err -> err `shouldBe` serial + Right deserial -> NSer.serialize deserial `shouldBe` serial + +serializesConsistentlyConversation :: NSer.Serializable a => a -> Expectation +serializesConsistentlyConversation serializable = + let serial = NSer.serialize serializable in + case VT.runAlex serial VG.parseConversation of + Left err -> err `shouldBe` serial + Right deserial -> NSer.serialize deserial `shouldBe` serial \ No newline at end of file From cc8870d2af5180cea1406fb9054226c454412c32 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Fri, 10 Mar 2023 17:11:29 +0100 Subject: [PATCH 208/229] Added Tests for Buffer --- src/Interpreter.hs | 2 -- test/BufferSpec.hs | 72 +++++++++++++++++++++++++++++++++++++++ test/NetworkBufferSpec.hs | 47 +++++++++++++++++++++++++ 3 files changed, 119 insertions(+), 2 deletions(-) create mode 100644 test/BufferSpec.hs create mode 100644 test/NetworkBufferSpec.hs diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 8e5520f..436dff6 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -260,9 +260,7 @@ interpretApp _ (VSend v@(VChan cc usedmvar)) w = do (env, (sockets, vchanconnections, activeConnections)) <- ask socketsraw <- liftIO $ MVar.readMVar sockets let port = show $ head $ Map.keys socketsraw - C.traceNetIO $ "Trying to send: " ++ show w liftIO $ NO.sendValue vchanconnections activeConnections cc w port (-2) - C.traceNetIO $ "Sent: " ++ show w -- Disable old VChan liftIO $ disableOldVChan v interpretApp e _ _ = throw $ ApplicationException e diff --git a/test/BufferSpec.hs b/test/BufferSpec.hs new file mode 100644 index 0000000..3028374 --- /dev/null +++ b/test/BufferSpec.hs @@ -0,0 +1,72 @@ +module BufferSpec (spec) where + +import Networking.Buffer +import Test.Hspec + +spec :: Spec +spec = do + describe "Buffer IO Test" $ do + it "Empty list" $ emptyBufferTest `shouldReturn` [] + it "Take from empty" $ tryTakeFromEmptyBufferTest `shouldReturn` Nothing + it "Read from empty" $ tryReadFromEmptyBufferTest `shouldReturn` Nothing + it "One Element in Buffer" $ (bufferWith42 >>= writeBufferToList) `shouldReturn` [42] + it "One Element in Clone" $ (bufferWith42AndClone >>= writeBufferToList . snd) `shouldReturn` [42] + it "Two Elements in Clone" $ (bufferWith42And1337AndClone >>= writeBufferToList . snd) `shouldReturn` [42, 1337] + it "Two Elements in Buffer" $ (bufferWith42And1337AndClone >>= writeBufferToList . fst) `shouldReturn` [42, 1337] + it "Try Read from Clone" $ (bufferWith42And1337AndClone >>= tryReadBuffer . snd) `shouldReturn` Just 42 + it "Read from Clone" $ (bufferWith42And1337AndClone >>= readBuffer . snd) `shouldReturn` 42 + it "Take from Clone" $ (bufferWith42And1337AndClone >>= takeBuffer . snd) `shouldReturn` 42 + it "Try Take from Clone" $ (bufferWith42And1337AndCloneTake42 >>= tryReadBuffer . snd) `shouldReturn` Just 1337 + it "Two Elements in Buffer #2" $ (bufferWith42And1337AndCloneTake42And1337 >>= writeBufferToList . fst) `shouldReturn` [42, 1337] + it "No Elements in Clone" $ (bufferWith42And1337AndCloneTake42And1337 >>= writeBufferToList . snd) `shouldReturn` [] + it "Three Elements in Buffer " $ (bufferWith42And1337And1AndCloneTake42And1337 >>= writeBufferToList . fst) `shouldReturn` [42, 1337, 1] + it "One Element in Clone #2" $ (bufferWith42And1337And1AndCloneTake42And1337 >>= writeBufferToList . snd) `shouldReturn` [1] + + + + +emptyBufferTest :: IO [Integer] +emptyBufferTest = newBuffer >>= writeBufferToList + +tryTakeFromEmptyBufferTest :: IO (Maybe Integer) +tryTakeFromEmptyBufferTest = newBuffer >>= tryTakeBuffer + +tryReadFromEmptyBufferTest :: IO (Maybe Integer) +tryReadFromEmptyBufferTest = newBuffer >>= tryReadBuffer + + +bufferWith42 :: IO (Buffer Integer) +bufferWith42 = do + newBuf <- newBuffer + writeBuffer newBuf 42 + return newBuf + +bufferWith42AndClone :: IO (Buffer Integer, Buffer Integer) +bufferWith42AndClone = do + buf <- bufferWith42 + clone <- cloneBuffer buf + return (buf, clone) + +bufferWith42And1337AndClone :: IO (Buffer Integer, Buffer Integer) +bufferWith42And1337AndClone = do + (buf, clone) <- bufferWith42AndClone + writeBuffer clone 1337 + return (buf, clone) + +bufferWith42And1337AndCloneTake42 :: IO (Buffer Integer, Buffer Integer) +bufferWith42And1337AndCloneTake42 = do + (buf, clone) <-bufferWith42And1337AndClone + takeBuffer clone + return (buf, clone) + +bufferWith42And1337AndCloneTake42And1337 :: IO (Buffer Integer, Buffer Integer) +bufferWith42And1337AndCloneTake42And1337 = do + (buf, clone) <-bufferWith42And1337AndCloneTake42 + tryTakeBuffer clone + return (buf, clone) + +bufferWith42And1337And1AndCloneTake42And1337 :: IO (Buffer Integer, Buffer Integer) +bufferWith42And1337And1AndCloneTake42And1337 = do + (buf, clone) <-bufferWith42And1337AndCloneTake42And1337 + writeBuffer buf 1 + return (buf, clone) \ No newline at end of file diff --git a/test/NetworkBufferSpec.hs b/test/NetworkBufferSpec.hs new file mode 100644 index 0000000..66f8bbe --- /dev/null +++ b/test/NetworkBufferSpec.hs @@ -0,0 +1,47 @@ +module NetworkBufferSpec (spec) where + +import Networking.Buffer +import Networking.NetworkBuffer +import Test.Hspec + +spec :: Spec +spec = do + describe "NetworkBuffer IO Test" $ do + it "All Acknowledged" $ (nb >>= isAllAcknowledged) `shouldReturn` True + it "Not All Acknowledged " $ (nb42 >>= isAllAcknowledged) `shouldReturn` False + it "Serialize" $ (nb42 >>= serializeMinimal) `shouldReturn` ([42], 0, 1) + it "Serialize #2" $ (nb42And1337 >>= serializeMinimal) `shouldReturn` ([42, 1337], 0, 2) + it "Try Read at 0" $ (nb42And1337 >>= \x -> tryGetAtNB x 0) `shouldReturn` Just 42 + it "Try Read at 1" $ (nb42And1337 >>= \x -> tryGetAtNB x 1) `shouldReturn` Just 1337 + it "Try Take" $ (nb42And1337 >>= tryTake) `shouldReturn` Just (42, 0) + it "Next Offset" $ (nb1337 >>= getNextOffset) `shouldReturn` 1 + it "Serialize #3" $ (nb1337 >>= serializeMinimal) `shouldReturn` ([1337], 1, 2) + it "All Acknowledged #2" $ (nb1337AllAck >>= isAllAcknowledged) `shouldReturn` True + it "Serialize #4" $ (nb1337AllAck >>= serializeMinimal) `shouldReturn` ([], 2, 2) + +nb :: IO (NetworkBuffer Integer) +nb = newNetworkBuffer + +nb42 :: IO (NetworkBuffer Integer) +nb42 = do + nb <- newNetworkBuffer + write nb 42 + return nb + +nb42And1337 :: IO (NetworkBuffer Integer) +nb42And1337 = do + nb <- nb42 + write nb 1337 + return nb + +nb1337 :: IO (NetworkBuffer Integer) +nb1337 = do + nb <- nb42And1337 + tryTake nb + return nb + +nb1337AllAck :: IO (NetworkBuffer Integer) +nb1337AllAck = do + nb <- nb1337 + updateAcknowledgements nb 1 + return nb From d16f2f1d773227b881c36bfea1c6157cda4d9a91 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Fri, 10 Mar 2023 17:35:44 +0100 Subject: [PATCH 209/229] Fixed compile warnings --- src/Networking/Serialize.hs | 1 - test/CSpec.hs | 1 - test/InterpreterSpec.hs | 1 - test/NetworkBufferSpec.hs | 1 - test/Utils.hs | 1 - 5 files changed, 5 deletions(-) diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index 05ed5a9..aee0f85 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -3,7 +3,6 @@ module Networking.Serialize where -import Control.Concurrent.Chan as Chan import Control.Exception import Data.Set import Kinds diff --git a/test/CSpec.hs b/test/CSpec.hs index da47b96..7077cc1 100644 --- a/test/CSpec.hs +++ b/test/CSpec.hs @@ -22,7 +22,6 @@ import C.Compile as C import C.Generate import Interpreter (interpret) import Parsing -import ProcessEnvironment import ProcessEnvironmentTypes import Typechecker (typecheck, Options(..)) import qualified Examples diff --git a/test/InterpreterSpec.hs b/test/InterpreterSpec.hs index 399776e..a0f1a57 100644 --- a/test/InterpreterSpec.hs +++ b/test/InterpreterSpec.hs @@ -6,7 +6,6 @@ import Utils import Kinds import Syntax import Interpreter -import ProcessEnvironment import ProcessEnvironmentTypes import UtilsFuncCcldlc diff --git a/test/NetworkBufferSpec.hs b/test/NetworkBufferSpec.hs index 66f8bbe..a64adaf 100644 --- a/test/NetworkBufferSpec.hs +++ b/test/NetworkBufferSpec.hs @@ -1,6 +1,5 @@ module NetworkBufferSpec (spec) where -import Networking.Buffer import Networking.NetworkBuffer import Test.Hspec diff --git a/test/Utils.hs b/test/Utils.hs index 9e49ded..9a97b57 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -3,7 +3,6 @@ module Utils where import Parsing import Syntax import Interpreter -import ProcessEnvironment import ProcessEnvironmentTypes import qualified Networking.Common as NC import qualified Networking.Serialize as NSer From 3ec8f976000a4d7a0d6f95b4abef080fa6032d44 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Fri, 10 Mar 2023 20:49:27 +0100 Subject: [PATCH 210/229] Update README-networking.md --- README-networking.md | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/README-networking.md b/README-networking.md index 8e95e24..14c406b 100644 --- a/README-networking.md +++ b/README-networking.md @@ -10,7 +10,7 @@ To run a LDGVNW example, found in the networking-examples folder, each program i The order in which these commands are executed is not relevant. -To test all the different test-cases in an easier way, they can be automatically run, with the scrips provided in the networking-tests folder. Simply running one of these scripts will run the whole test-case at once. +To test all the different test-cases in an easier way, they can be automatically run, with the scrips provided in the networking-tests folder. Simply running one of these scripts will execute the whole test-case at once. The testNW\* scripts contain all the tests, except for the recursion test. @@ -69,7 +69,7 @@ Following that, A and B can send and recv values analog to Channels created with ## Sending messages over a Connection When communication partner A executes a send instruction to send Value V to B, A first analyses V. Should V be or contain a Channel C, A will set a flag for in C to redirect new messages to the address of B. -After that, C will be converted to a serializable form CS. +After that, C will be converted to a serializable form, CS. With every channel now being in a form which can be sent over the network, A now writes V to its write-buffer and sends B a NewValue message containing V. Upon receiving V as B with the recv instruction, B now undoes the conversion of every Channel in V from CS to C. And contacts the communication partner of each Channel, to inform them that their new communication partner is now B instead of A. @@ -115,13 +115,13 @@ It is important to note that VChans only should be serialized after their Connec ## Why Values are Acknowledged LDGVNW has separate messages for sending a Value (NewValue) and acknowledging a Value (AcknowledgeValue). Simply knowing that the other party has received a Value, isn't enough when Channels are involved. -Let's say there is a Channel C, between A and B. A sends their end of C to D and at the same time B sends their end of C to E. Since the sending of the Channel ends, happened simultaneously, D still thinks they are talking to B and E thinks they are talking to A. Should A and B now go offline, before either D or E, can contact them to find out where they redirected their connections to, D and E will not be able to connect. Since acknowledgements are only sent after a sent Channel has been reconnected, it can be assured that D and E are connected, before A and B can go offline. +Let's say there is a Channel C, between A and B. A sends their end of C to D and at the same time, B sends their end of C to E. Since the sending of the Channel ends, happened simultaneously, D still thinks they are talking to B and E thinks they are talking to A. Should A and B now go offline, before either D or E, can contact them to find out where they redirected their connections to, D and E will not be able to connect. Since acknowledgments are only sent after a sent Channel has been reconnected, it can be assured that D and E are connected, before A and B can go offline. -It would be also possible to use a Response to the NewValue message, to signal that the Value got acknowledged, but I decided to split this process into two messages, since the acknowledging can take long time, compared to other messages. +It would also be possible to use a Response to the NewValue message, to signal that the Value got acknowledged, but I decided to split this process into two messages, since the acknowledging can take long time, compared to other messages. ## A communication example -In the [communication example](README-networking-communication-example.md) gives a concrete example for the communication protocol. +In the [communication example](README-networking-communication-example.md) gives a concrete example of the communication protocol. # Serializing and Sending Messages The logical messages are serialized first, then are sent either using a fast protocol which reuses existing connections or a stateless protocol, which was primary used during development as a fallback when the fast protocol wasn't working yet. @@ -151,3 +151,5 @@ Internal channels (channels in the same program, created with new) and external + + From 911e4dc22a9aa3b6f54d55517f9abc0d7791bd77 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sat, 11 Mar 2023 16:54:27 +0100 Subject: [PATCH 211/229] Update README-networking.md --- README-networking.md | 41 +++++++++++++++++------------------------ 1 file changed, 17 insertions(+), 24 deletions(-) diff --git a/README-networking.md b/README-networking.md index 14c406b..56c85f5 100644 --- a/README-networking.md +++ b/README-networking.md @@ -1,5 +1,4 @@ # How to run LDGVNW - Using LDGVNW is a little more difficult than simply starting a single program. In addition to the requirements of LDGV, you also need a network connected via IPv4. Should this network span more than one device, the IP-addresses within the LDGVNW programs need to be altered to reflect this architecture. The current version of LDGVNW was tested on Fedora 37 and macOS 13.2 and should work on every recent Linux or macOS machine, it is unknown whether LDGVNW works on Windows machines. To run a LDGVNW example, found in the networking-examples folder, each program in the example folder needs to be run. To start the "handoff" example, you would run the following commands in different terminals or on different machines: @@ -15,11 +14,10 @@ The testNW\* scripts contain all the tests, except for the recursion test. # An Introduction to LDGVNW - LDGVNW adds two new commands to LDGV to allow for networking capabilities: - `accept ` -- `connect ` +- `connect ` The accept command requires an integer as a port for others to connect and a type that will be required of a connecting connection. Once a communication partner connects with a desired type, the accept command will return a VChan. @@ -29,9 +27,8 @@ Important to note is that, with the current implementation, only IPv4 addresses IPv6 and Unix domain sockets could be supported in the future with a relatively low effort. # The Logical Communication Architecture - ## Messages and Responses -In LDGVNW, there are 7 possible Messages and 4 possible Responses. +In LDGVNW, there are 7 possible Messages and 5 possible Responses. The messages are: - `Introduce ` @@ -48,6 +45,7 @@ With possible responses: - `Okay` - `OkayIntroduce ` - `Wait` +- `Error` Typing for the attributes: @@ -71,8 +69,8 @@ When communication partner A executes a send instruction to send Value V to B, A Should V be or contain a Channel C, A will set a flag for in C to redirect new messages to the address of B. After that, C will be converted to a serializable form, CS. With every channel now being in a form which can be sent over the network, A now writes V to its write-buffer and sends B a NewValue message containing V. -Upon receiving V as B with the recv instruction, B now undoes the conversion of every Channel in V from CS to C. -And contacts the communication partner of each Channel, to inform them that their new communication partner is now B instead of A. +Upon receiving V as B with the recv instruction, B now undoes the conversion of every Channel in V. +B then contacts the communication partner of each Channel, to inform them that their new communication partner is now B instead of A. After this, B sends an acknowledgment (AcknowledgeValue message) back to A, which finalizes the sending of V. A can now remove V out of its write-buffer. @@ -80,6 +78,7 @@ A can now remove V out of its write-buffer. Except for the Introduce message, every message should be answered with an Okay response. Exceptions to that are Redirect responses, which are used when a message is sent to an outdated address or Wait responses, which are sent when a message cannot be handled at the current moment. This can happen when the communication partner is already handling a message in a critical section, or a communication partner is currently in the progress of sending the Channel which the message is sent to. +Lastly, there is also an Error response, which is sent, when an error occurred while handling a message. This is currently only used by the AcknowledgePartnerAddress message. ## Informing communication partners of a communication partner change If there is a Channel C between A and B and A sends their side of the Channel to D, B needs to be made aware of that. @@ -88,10 +87,9 @@ B then replies with a AcknowledgePartnerAddress message, repeating DC. As soon as the address is established, C is considered successfully received by D. ## Shutting down after completing all the instructions -After A finishes the interpretation of their program, A waits until all messages it sent were acknowledged by their communication partners. After that, A sends a Disconnect message to all its peers. The Disconnect message is needed to avoid rewriting a large portion of the interpreter to annotate each expression with their associated output Types. Should the Disconnect message not exist, it would be theoretically possible to send a Unit-Type of an exhausted Channel to another communication partner. The recipient would now be unknowing whether their new communication partner were still online. +After A finishes the interpretation of their program, A waits until all messages it sent were acknowledged by their communication partners. After that, A sends a Disconnect message to all its peers. The Disconnect message is needed to avoid rewriting a large portion of the interpreter to annotate each recv expression with their associated output Types. Should the Disconnect message not exist, it would be theoretically possible to send a Unit-Type of an exhausted Channel to another communication partner. The recipient would now be unknowing whether their new communication partner were still online. ## Converting between VChans and VChanSerials - Since VChans can't be serialized directly, they need to be converted into VChanSerials first. VChans have the following (simplified) architecture: `VChan ` @@ -100,7 +98,7 @@ The contained NetworkConnection has this architecture: `NetworkConnection ` -The relevant part, for the conversion to VChanSerials, is found in the NetworkConnection. The ReadBuffer contains Values that are not yet handled, while the WriteBuffer contains Values that are not yet acknowledged by the communication partner. The implementation of these Buffers is based on the implementation of the Chan types of Haskell, this is also noted and acknowledged in the Buffer module. The PartnerID and OwnID are strings to identify the logical communication partner, these do not change when sent to another communication partner. Lastly, the ConnectionState contains information about whether the connection is an external connection, an internal connection, among other things. +The relevant part, for the conversion to VChanSerials, is found in the NetworkConnection. The ReadBuffer contains Values that are not yet handled, while the WriteBuffer contains Values that are not yet acknowledged by the communication partner. The implementation of these Buffers is based on the implementation of the Chan types of Haskell, this is also noted and acknowledged in the Buffer module. The PartnerID and OwnID are strings to identify the logical communication partner, these do not change when sent to another communication partner. Lastly, the ConnectionState contains information about whether the connection is an external connection, an internal connection, offline or should be redirected to another communication partner. The VChanSerial has the following architecture: @@ -110,21 +108,19 @@ The ReadList contains the current elements of the ReadBuffer, the ReadOffset con To convert a VChanSerial to a VChan an empty VChan is simply filled with the data provided by the VChanSerial. -It is important to note that VChans only should be serialized after their ConnectionState has been set to Redirect. This freezes the VChan, as it can no longer receive new messages. This way it can be assured, that at the time of receipt, both the original VChan and the one generated from the VChanSerial contain the identical data. +It is important to note that VChans only should be serialized after their ConnectionState has been set to Redirect. This freezes the VChan, as it can no longer receive new messages. This way it can be assured, that at the time of receipt, both the original VChan and the one generated from the VChanSerial contain identical data. ## Why Values are Acknowledged - LDGVNW has separate messages for sending a Value (NewValue) and acknowledging a Value (AcknowledgeValue). Simply knowing that the other party has received a Value, isn't enough when Channels are involved. Let's say there is a Channel C, between A and B. A sends their end of C to D and at the same time, B sends their end of C to E. Since the sending of the Channel ends, happened simultaneously, D still thinks they are talking to B and E thinks they are talking to A. Should A and B now go offline, before either D or E, can contact them to find out where they redirected their connections to, D and E will not be able to connect. Since acknowledgments are only sent after a sent Channel has been reconnected, it can be assured that D and E are connected, before A and B can go offline. It would also be possible to use a Response to the NewValue message, to signal that the Value got acknowledged, but I decided to split this process into two messages, since the acknowledging can take long time, compared to other messages. ## A communication example - In the [communication example](README-networking-communication-example.md) gives a concrete example of the communication protocol. # Serializing and Sending Messages -The logical messages are serialized first, then are sent either using a fast protocol which reuses existing connections or a stateless protocol, which was primary used during development as a fallback when the fast protocol wasn't working yet. +The logical messages are serialized first, then are sent either using a fast protocol, which reuses existing connections or a stateless protocol, which was primary used during development as a fallback when the fast protocol wasn't working yet. ## Serialization Messages and Responses in LDGVNW are serialized into ASCII-Strings and follow the form of the name of the Message, Value, etc. followed by their arguments in brackets. For instance, the message `NewValue <2> ` would be translated to `NNewValue (String:"abcd1234") (Int:2) (VInt (Int:42))` @@ -132,7 +128,7 @@ Messages and Responses in LDGVNW are serialized into ASCII-Strings and follow th To deserialize these messages, the alex and happy libraries are used. ## Stateless Protocol -The stateless protocol allows sending serialized logical messages directly, by establishing a new connection, sending the serialized message, waiting for a response and disconnecting afterward. By always creating new connections, it can be assured that every message gets its correct response, but establishing a new TCP connection every time a message is sent, also causes a huge performance penalty. The stateless protocol creates a new temporary thread to handle each incoming message. Messages are primarily sent from the main thread, in which also the interpretation occurs, except for some messages like the acknowledging of a new partner address, which is sent from the temporary thread. +The stateless protocol allows sending serialized logical messages directly, by establishing a new connection, sending the serialized message, waiting for a response and disconnecting afterward. By always creating new connections, it can be assured that every message gets its correct response, but establishing a new TCP connection every time a message is sent, also causes a performance penalty. The stateless protocol creates a new temporary thread to handle each incoming message. Messages are primarily sent from the main thread, in which also the interpretation occurs, except for some messages like the acknowledging of a new partner address, which is sent from the temporary thread. ## Fast Protocol The fast protocol saves a once created TCP connection and reuses it as long as it stays open. Since LDGVNW uses multiple threads to send messages, this can lead to messages and responses being mismatched. To avoid this, each Message and Response is wrapped in a ConversationSession. @@ -141,15 +137,12 @@ The fast protocol saves a once created TCP connection and reuses it as long as i - `ConversationResponse ` - `ConversationCloseAll` -The ConversationID is a random string, selected by the sender of the message and copied by the respondent. ConversationCloseAll is used when one party wants to close all connections to a peer, signaling to their peer that they would need to establish a new connection if they would like to talk to this port again. -Each connection gets their own thread where new incoming messages and responses are collected. Messages also get automatically handled, while responses can be picked up by the sending function, to determine its further behavior. +The ConversationID is a random string, selected by the sender of the message and copied by the respondent. ConversationCloseAll is used when one party wants to close all connections to a peer, signaling to their peer that they would need to establish a new connection if they would like to talk to this address and port again. +This is helpful if there are A and B. A has an address and port combination of AP. After A and B are done communicating, A goes offline and sends an ConversationCloseAll. Now, C can reuse AP to talk to B. +Each TCP connection gets its own thread where new incoming messages and responses are collected. Each Channel also gets its own thread where incoming messages get handled. Responses can be picked up by the sending function, to determine its further behavior. Similar to the stateless protocol, most messages are sent from the main thread, while some messages are sent from a connection specific thread. # Compatibility between Internal and External Channels - -Internal channels (channels in the same program, created with new) and external channels (channels between two programs, created with connect and accept) are handled for the most part the same way in LDGVNW. Every channel has a NetworkConnection object, which saves both incoming and outgoing messages, it also has a ConnectionState object, which dictates whether a NetworkConnection is internal or external. Should an internal connection be sent to a peer, the internal connection gets converted into an external connection. Should both sides of an external connection end up in the same program, the connection will be converted to an internal connection. - - - - - +Internal channels (channels in the same program, created with new) and external channels (channels between two programs, created with connect and accept) are handled the same way in LDGVNW, for the most part. Every channel has a NetworkConnection object, which saves both incoming and outgoing messages, it also has a ConnectionState object, which dictates whether a NetworkConnection is internal or external. +In contrast to external Channels, which serialize and send messages, internal Channels write the data of these messages directly to their counterparts. +Should an internal Channel be sent to a peer, the internal Channel gets converted into an external Channel. Should both sides of an external Channel end up in the same program, the connection will be converted to an internal Channel. \ No newline at end of file From 531f9aee4fce64a8d505c5e050d3f190877db37c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sun, 12 Mar 2023 17:43:26 +0100 Subject: [PATCH 212/229] Serialization now looks like it did previously --- src/Networking/Serialize.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index aee0f85..0993061 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -30,7 +30,7 @@ instance SerializableList String where toSer = id instance (SerializableList b, Serializable a) => SerializableList (a -> b) where - toSer serList serElem = toSer $ serList ++ "(" ++ serialize serElem ++ ")" + toSer serList serElem = toSer $ serList ++ " (" ++ serialize serElem ++ ")" merge :: (SerializableList b) => b merge = toSer "" From a07ceb417f071f685e5a48b34ec6655b9515f98b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Sun, 12 Mar 2023 19:54:06 +0100 Subject: [PATCH 213/229] Update README-networking.md --- README-networking.md | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/README-networking.md b/README-networking.md index 56c85f5..4c2bd07 100644 --- a/README-networking.md +++ b/README-networking.md @@ -53,7 +53,7 @@ Typing for the attributes: - **ConnectionID** is a unique string, used to identify the current physical connection to a logical communication partner - **Port** is a string containing the number of a port - **Address** is a string containing the IPv4 address or URL of a communication partner -- **Value** is a data-type in LDGV. The VChans present in this Value are replaced with VChanSerials +- **Value** is a type of data in LDGV. The VChans present in this Value are replaced with VChanSerials - **Value Index** is an integer containing the index of a Value - **Type Name** is a TName Type of the desired Type - **Type Structure** of the desired Type @@ -66,7 +66,7 @@ Following that, A and B can send and recv values analog to Channels created with ## Sending messages over a Connection When communication partner A executes a send instruction to send Value V to B, A first analyses V. -Should V be or contain a Channel C, A will set a flag for in C to redirect new messages to the address of B. +Should V be or contain a Channel C, A will set a flag in C to redirect new messages to the address of B. After that, C will be converted to a serializable form, CS. With every channel now being in a form which can be sent over the network, A now writes V to its write-buffer and sends B a NewValue message containing V. Upon receiving V as B with the recv instruction, B now undoes the conversion of every Channel in V. @@ -75,10 +75,14 @@ After this, B sends an acknowledgment (AcknowledgeValue message) back to A, whic A can now remove V out of its write-buffer. ## Responding to Messages -Except for the Introduce message, every message should be answered with an Okay response. -Exceptions to that are Redirect responses, which are used when a message is sent to an outdated address or Wait responses, which are sent when a message cannot be handled at the current moment. -This can happen when the communication partner is already handling a message in a critical section, or a communication partner is currently in the progress of sending the Channel which the message is sent to. -Lastly, there is also an Error response, which is sent, when an error occurred while handling a message. This is currently only used by the AcknowledgePartnerAddress message. +Except for the Introduce message, every message should be ideally answered with an Okay response. +But in some cases the messages don't arrive at the right communication partner or at the wrong time. In these cases, other responses are used. +- Redirect responses are sent when a message is sent to an outdated address +- Wait responses are sent when a message cannot be handled at the current moment + - This can be caused by currently being in a critical section while handling another message + - During the sending process of a Channel + - When the addressed Channel isn't yet known by the program +- Error responses are sent when an error occurs while handling a AcknowledgePartnerAddress message ## Informing communication partners of a communication partner change If there is a Channel C between A and B and A sends their side of the Channel to D, B needs to be made aware of that. @@ -89,22 +93,22 @@ As soon as the address is established, C is considered successfully received by ## Shutting down after completing all the instructions After A finishes the interpretation of their program, A waits until all messages it sent were acknowledged by their communication partners. After that, A sends a Disconnect message to all its peers. The Disconnect message is needed to avoid rewriting a large portion of the interpreter to annotate each recv expression with their associated output Types. Should the Disconnect message not exist, it would be theoretically possible to send a Unit-Type of an exhausted Channel to another communication partner. The recipient would now be unknowing whether their new communication partner were still online. -## Converting between VChans and VChanSerials -Since VChans can't be serialized directly, they need to be converted into VChanSerials first. VChans have the following (simplified) architecture: - +## Making Channels serializable +Making Channels sendable was one of the biggest focuses of LDGVNW. +VChans are Channels that are directly useable by LDGV, but since VChans can't be serialized directly, they need to be converted into VChanSerials first. VChans have the following (simplified) architecture: `VChan ` The contained NetworkConnection has this architecture: `NetworkConnection ` -The relevant part, for the conversion to VChanSerials, is found in the NetworkConnection. The ReadBuffer contains Values that are not yet handled, while the WriteBuffer contains Values that are not yet acknowledged by the communication partner. The implementation of these Buffers is based on the implementation of the Chan types of Haskell, this is also noted and acknowledged in the Buffer module. The PartnerID and OwnID are strings to identify the logical communication partner, these do not change when sent to another communication partner. Lastly, the ConnectionState contains information about whether the connection is an external connection, an internal connection, offline or should be redirected to another communication partner. +The relevant part, for the conversion to VChanSerials, is found in the NetworkConnection. The ReadBuffer contains Values, that are not yet handled, while the WriteBuffer contains Values, that are not yet acknowledged by the communication partner. The implementation of these Buffers is based on the implementation of the Chan type of Haskell, this is also noted and acknowledged in the Buffer module. The PartnerID and OwnID are strings to identify the logical communication partner, these do not change when sent to another communication partner. Lastly, the ConnectionState contains information about whether the connection is an external connection, an internal connection, offline or should be redirected to another communication partner. The VChanSerial has the following architecture: `VChanSerial
` -The ReadList contains the current elements of the ReadBuffer, the ReadOffset contains the logical index of the first element of the ReadBuffer, and the ReadLength is the number of all logical elements in the buffer. As an example, let's say 5 Values were received, but the first 3 already were handled, so the ReadList would contain 2 elements, the ReadOffset would be 3 and the ReadLength would be 5. The WriteList, WriteOffset and WriteLength behave analogously. The PartnerID and OwnID are directly taken from the NetworkConnection and the Address, Port and ConnectionID (from the partner) are taken from the ConnectionState. +The ReadList contains the current elements of the ReadBuffer, the ReadOffset contains the logical index of the first element of the ReadBuffer, and the ReadLength is the number of all logical elements in the buffer. For example, let's say 5 Values were received, but the first 3 already were handled, so the ReadList would contain 2 elements, the ReadOffset would be 3 and the ReadLength would be 5. The WriteList, WriteOffset and WriteLength behave analogously. The PartnerID and OwnID are directly taken from the NetworkConnection and the Address, Port and ConnectionID (from the partner) are taken from the ConnectionState. To convert a VChanSerial to a VChan an empty VChan is simply filled with the data provided by the VChanSerial. From e11c0802ec633bd5e0151a96e138c668f998f1c8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 13 Mar 2023 12:59:34 +0100 Subject: [PATCH 214/229] Added proper typecheck to accept and connect --- README-networking.md | 14 +++++++------- newsyntax.txt | 2 -- src/TCTyping.hs | 30 +++++++++++++++++++++++++++++- syntax.txt | 5 +++++ 4 files changed, 41 insertions(+), 10 deletions(-) delete mode 100644 newsyntax.txt diff --git a/README-networking.md b/README-networking.md index 4c2bd07..d36940f 100644 --- a/README-networking.md +++ b/README-networking.md @@ -68,7 +68,7 @@ Following that, A and B can send and recv values analog to Channels created with When communication partner A executes a send instruction to send Value V to B, A first analyses V. Should V be or contain a Channel C, A will set a flag in C to redirect new messages to the address of B. After that, C will be converted to a serializable form, CS. -With every channel now being in a form which can be sent over the network, A now writes V to its write-buffer and sends B a NewValue message containing V. +With every Channel now being in a form which can be sent over the network, A now writes V to its write-buffer and sends B a NewValue message containing V. Upon receiving V as B with the recv instruction, B now undoes the conversion of every Channel in V. B then contacts the communication partner of each Channel, to inform them that their new communication partner is now B instead of A. After this, B sends an acknowledgment (AcknowledgeValue message) back to A, which finalizes the sending of V. @@ -77,12 +77,12 @@ A can now remove V out of its write-buffer. ## Responding to Messages Except for the Introduce message, every message should be ideally answered with an Okay response. But in some cases the messages don't arrive at the right communication partner or at the wrong time. In these cases, other responses are used. -- Redirect responses are sent when a message is sent to an outdated address -- Wait responses are sent when a message cannot be handled at the current moment +- **Redirect** responses are sent when a message is sent to an outdated address +- **Wait** responses are sent when a message cannot be handled at the current moment - This can be caused by currently being in a critical section while handling another message - During the sending process of a Channel - - When the addressed Channel isn't yet known by the program -- Error responses are sent when an error occurs while handling a AcknowledgePartnerAddress message + - When the addressed Channel isn't yet known by the program +- **Error** responses are sent when an error occurs while handling a AcknowledgePartnerAddress message ## Informing communication partners of a communication partner change If there is a Channel C between A and B and A sends their side of the Channel to D, B needs to be made aware of that. @@ -121,7 +121,7 @@ Let's say there is a Channel C, between A and B. A sends their end of C to D and It would also be possible to use a Response to the NewValue message, to signal that the Value got acknowledged, but I decided to split this process into two messages, since the acknowledging can take long time, compared to other messages. ## A communication example -In the [communication example](README-networking-communication-example.md) gives a concrete example of the communication protocol. +The [communication example](README-networking-communication-example.md) gives a concrete example of the communication protocol. # Serializing and Sending Messages The logical messages are serialized first, then are sent either using a fast protocol, which reuses existing connections or a stateless protocol, which was primary used during development as a fallback when the fast protocol wasn't working yet. @@ -147,6 +147,6 @@ Each TCP connection gets its own thread where new incoming messages and response Similar to the stateless protocol, most messages are sent from the main thread, while some messages are sent from a connection specific thread. # Compatibility between Internal and External Channels -Internal channels (channels in the same program, created with new) and external channels (channels between two programs, created with connect and accept) are handled the same way in LDGVNW, for the most part. Every channel has a NetworkConnection object, which saves both incoming and outgoing messages, it also has a ConnectionState object, which dictates whether a NetworkConnection is internal or external. +Internal Channels (Channels in the same program, created with new) and external Channels (Channels between two programs, created with connect and accept) are handled the same way in LDGVNW, for the most part. Every Channel has a NetworkConnection object, which saves both incoming and outgoing messages, it also has a ConnectionState object, which dictates whether a NetworkConnection is internal or external. In contrast to external Channels, which serialize and send messages, internal Channels write the data of these messages directly to their counterparts. Should an internal Channel be sent to a peer, the internal Channel gets converted into an external Channel. Should both sides of an external Channel end up in the same program, the connection will be converted to an internal Channel. \ No newline at end of file diff --git a/newsyntax.txt b/newsyntax.txt deleted file mode 100644 index 2568e88..0000000 --- a/newsyntax.txt +++ /dev/null @@ -1,2 +0,0 @@ -create -- Creates a server socket -connect -- Connects to a server \ No newline at end of file diff --git a/src/TCTyping.hs b/src/TCTyping.hs index 379f7c8..eb5f610 100644 --- a/src/TCTyping.hs +++ b/src/TCTyping.hs @@ -242,11 +242,39 @@ tySynth te e = kiCheck (demoteTE te) ty Kssn return (TPair "" ty (dualof ty), te) -- I've got no real clue of what I am doing here hope it kind of works - Connect e0 ty e1 e2 -> do + Connect e1 ty e2 e3 -> do kiCheck (demoteTE te) ty Kssn + -- check whether e1 is Int + (top, te1) <- tySynth te e1 + topu <- unfold te1 top + case topu of + TInt -> return () + TNat -> return () + _ -> TC.mfail ("Int expected, but got " ++ pshow top ++ " (" ++ pshow topu ++ ")") + -- check whether e2 is String + (tps, te2) <- tySynth te e2 + tpsu <- unfold te2 tps + case tpsu of + TString -> return () + _ -> TC.mfail ("String expected, but got " ++ pshow tps ++ " (" ++ pshow tpsu ++ ")") + -- check whether e3 is Int + (tpp, te3) <- tySynth te e3 + tppu <- unfold te3 tpp + case tppu of + TInt -> return () + TNat -> return () + _ -> TC.mfail ("Int expected, but got " ++ pshow tpp ++ " (" ++ pshow tppu ++ ")") + return (ty, te) Accept e1 ty -> do kiCheck (demoteTE te) ty Kssn + -- check whether e1 is Int + (top, te1) <- tySynth te e1 + topu <- unfold te1 top + case topu of + TInt -> return () + TNat -> return () + _ -> TC.mfail ("Int expected, but got " ++ pshow top ++ " (" ++ pshow topu ++ ")") return (ty, te) Send e1 -> do (ts, te1) <- tySynth te e1 diff --git a/syntax.txt b/syntax.txt index a445f28..0b982a8 100644 --- a/syntax.txt +++ b/syntax.txt @@ -72,6 +72,11 @@ M ::= "()" | "case" M "of" "{" lab ":" M { "," lab ":" M } "}" | "(" M ")" +## LDGVNW: + + | accept Int T + | connect Int T String Int + ## later: | "select" lab From 1d321dc9b2d5c2be5c87a8190777e053113f9e4e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 13 Mar 2023 13:39:41 +0100 Subject: [PATCH 215/229] Added new test --- networking-examples/sendString/client.ldgvnw | 8 ++++++++ networking-examples/sendString/server.ldgvnw | 9 +++++++++ networking-tests/testNWCount.sh | 1 + networking-tests/testNWCountHigh.sh | 1 + syntax.txt | 1 + 5 files changed, 20 insertions(+) create mode 100644 networking-examples/sendString/client.ldgvnw create mode 100644 networking-examples/sendString/server.ldgvnw diff --git a/networking-examples/sendString/client.ldgvnw b/networking-examples/sendString/client.ldgvnw new file mode 100644 index 0000000..95bae13 --- /dev/null +++ b/networking-examples/sendString/client.ldgvnw @@ -0,0 +1,8 @@ +type SendString : ! ~ssn = !String. ?String. Unit + +val main : String +val main = + let con = (connect 4343 SendString "127.0.0.1" 4242 ) in + let con2 = (send con) "Hello" in + let = recv con2 in + (world) diff --git a/networking-examples/sendString/server.ldgvnw b/networking-examples/sendString/server.ldgvnw new file mode 100644 index 0000000..10f7345 --- /dev/null +++ b/networking-examples/sendString/server.ldgvnw @@ -0,0 +1,9 @@ +type SendString : ! ~ssn = !String. ?String. Unit + +val main : String +val main = + let con = (accept 4242 (dualof SendString)) in + let = recv con in + let con3 = (send con2) "world" in + (hello) + diff --git a/networking-tests/testNWCount.sh b/networking-tests/testNWCount.sh index 81f0aea..60fd7d7 100644 --- a/networking-tests/testNWCount.sh +++ b/networking-tests/testNWCount.sh @@ -1,5 +1,6 @@ for i in {1..10}; do clear; echo "$i Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/add/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/add/client.ldgvnw & wait); + clear; echo "$i SendString"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/sendString/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/sendString/client.ldgvnw & wait); clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/simple/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/simple/client.ldgvnw & wait); clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirectional/client.ldgvnw & wait); clear; echo "$i Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/client.ldgvnw & wait); diff --git a/networking-tests/testNWCountHigh.sh b/networking-tests/testNWCountHigh.sh index f3aa3db..13e23bb 100644 --- a/networking-tests/testNWCountHigh.sh +++ b/networking-tests/testNWCountHigh.sh @@ -1,5 +1,6 @@ for i in {1..20000}; do clear; echo "$i Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/add/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/add/client.ldgvnw & wait); + clear; echo "$i SendString"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/sendString/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/sendString/client.ldgvnw & wait); clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/simple/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/simple/client.ldgvnw & wait); clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirectional/client.ldgvnw & wait); clear; echo "$i Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/client.ldgvnw & wait); diff --git a/syntax.txt b/syntax.txt index 0b982a8..e5205f1 100644 --- a/syntax.txt +++ b/syntax.txt @@ -40,6 +40,7 @@ lab ::= "'" id T ::= "Unit" | "Int" | "Bot" + | "String" | TID | "{" lab { "," lab } "}" | "case" M "of" "{" lab ":" T { "," lab ":" T } "}" From 488eb8ab1104e660e7a9d3baa91352eddb88c204 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 13 Mar 2023 15:45:57 +0100 Subject: [PATCH 216/229] Update README-networking.md --- README-networking.md | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/README-networking.md b/README-networking.md index d36940f..26f841e 100644 --- a/README-networking.md +++ b/README-networking.md @@ -94,7 +94,7 @@ As soon as the address is established, C is considered successfully received by After A finishes the interpretation of their program, A waits until all messages it sent were acknowledged by their communication partners. After that, A sends a Disconnect message to all its peers. The Disconnect message is needed to avoid rewriting a large portion of the interpreter to annotate each recv expression with their associated output Types. Should the Disconnect message not exist, it would be theoretically possible to send a Unit-Type of an exhausted Channel to another communication partner. The recipient would now be unknowing whether their new communication partner were still online. ## Making Channels serializable -Making Channels sendable was one of the biggest focuses of LDGVNW. +One of the main focuses of LDGVNW was to send Channels over the network. VChans are Channels that are directly useable by LDGV, but since VChans can't be serialized directly, they need to be converted into VChanSerials first. VChans have the following (simplified) architecture: `VChan ` @@ -143,10 +143,11 @@ The fast protocol saves a once created TCP connection and reuses it as long as i The ConversationID is a random string, selected by the sender of the message and copied by the respondent. ConversationCloseAll is used when one party wants to close all connections to a peer, signaling to their peer that they would need to establish a new connection if they would like to talk to this address and port again. This is helpful if there are A and B. A has an address and port combination of AP. After A and B are done communicating, A goes offline and sends an ConversationCloseAll. Now, C can reuse AP to talk to B. -Each TCP connection gets its own thread where new incoming messages and responses are collected. Each Channel also gets its own thread where incoming messages get handled. Responses can be picked up by the sending function, to determine its further behavior. +Each TCP connection gets its own thread, where new incoming messages and responses are collected. Each Channel also gets its own thread, where incoming messages get handled. Responses can be picked up by the sending function, to determine its further behavior. Similar to the stateless protocol, most messages are sent from the main thread, while some messages are sent from a connection specific thread. # Compatibility between Internal and External Channels -Internal Channels (Channels in the same program, created with new) and external Channels (Channels between two programs, created with connect and accept) are handled the same way in LDGVNW, for the most part. Every Channel has a NetworkConnection object, which saves both incoming and outgoing messages, it also has a ConnectionState object, which dictates whether a NetworkConnection is internal or external. +Internal Channels (Channels in the same program, created with new) and external Channels (Channels between two programs, created with connect and accept) are handled, for the most part, the same way in LDGVNW. Every Channel has a NetworkConnection object. The NetworkConnection object saves both incoming and outgoing messages and a ConnectionState. The ConnectionState object dictates whether a NetworkConnection is internal or external. In contrast to external Channels, which serialize and send messages, internal Channels write the data of these messages directly to their counterparts. -Should an internal Channel be sent to a peer, the internal Channel gets converted into an external Channel. Should both sides of an external Channel end up in the same program, the connection will be converted to an internal Channel. \ No newline at end of file +Should an internal Channel be sent to a peer, the internal Channel gets converted into an external Channel. Should both sides of an external Channel end up in the same program, the connection will be converted to an internal Channel. + From 5d70333c9662ff9f09665366f73dc2451df589f0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 13 Mar 2023 16:29:23 +0100 Subject: [PATCH 217/229] Added new test --- networking-examples/twoCons/client.ldgvnw | 29 +++++++++++++++++++++++ networking-examples/twoCons/server.ldgvnw | 29 +++++++++++++++++++++++ networking-tests/testNWCount.sh | 1 + networking-tests/testNWCountHigh.sh | 1 + networking-tests/testOftenTwoCons.sh | 3 +++ 5 files changed, 63 insertions(+) create mode 100644 networking-examples/twoCons/client.ldgvnw create mode 100644 networking-examples/twoCons/server.ldgvnw create mode 100644 networking-tests/testOftenTwoCons.sh diff --git a/networking-examples/twoCons/client.ldgvnw b/networking-examples/twoCons/client.ldgvnw new file mode 100644 index 0000000..1db9891 --- /dev/null +++ b/networking-examples/twoCons/client.ldgvnw @@ -0,0 +1,29 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit +type ComInt : ! ~ssn = !Int. ?Int. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let y = ((send x) 42) in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val com2C (c2: ComInt) = + let x = ((send c2) 1337) in + let = recv x in + (n) + +val main : Int +val main = + let con = (connect 4343 SendInt "127.0.0.1" 4242 ) in + let con2 = (connect 4343 ComInt "127.0.0.1" 4242 ) in + let s2 = fork (send2 con) in + com2C con2 + + diff --git a/networking-examples/twoCons/server.ldgvnw b/networking-examples/twoCons/server.ldgvnw new file mode 100644 index 0000000..96e37df --- /dev/null +++ b/networking-examples/twoCons/server.ldgvnw @@ -0,0 +1,29 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit +type ComInt : ! ~ssn = !Int. ?Int. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let y = ((send x) 42) in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + () + +val com2S (c2: dualof ComInt) = + let = recv c2 in + let y = (send x) 42 in + (n) + +val main : Int +val main = + -- let sock = (create 4242) in + let con = (accept 4242 (dualof SendInt)) in + let con2 = (accept 4242 (dualof ComInt)) in + let a2 = fork (add2 con) in + let cS = com2S con2 in + (cS) diff --git a/networking-tests/testNWCount.sh b/networking-tests/testNWCount.sh index 60fd7d7..a14ce4a 100644 --- a/networking-tests/testNWCount.sh +++ b/networking-tests/testNWCount.sh @@ -1,6 +1,7 @@ for i in {1..10}; do clear; echo "$i Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/add/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/add/client.ldgvnw & wait); clear; echo "$i SendString"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/sendString/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/sendString/client.ldgvnw & wait); + clear; echo "$i TwoCons"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/twoCons/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/twoCons/client.ldgvnw & wait); clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/simple/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/simple/client.ldgvnw & wait); clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirectional/client.ldgvnw & wait); clear; echo "$i Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/client.ldgvnw & wait); diff --git a/networking-tests/testNWCountHigh.sh b/networking-tests/testNWCountHigh.sh index 13e23bb..abb9496 100644 --- a/networking-tests/testNWCountHigh.sh +++ b/networking-tests/testNWCountHigh.sh @@ -1,6 +1,7 @@ for i in {1..20000}; do clear; echo "$i Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/add/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/add/client.ldgvnw & wait); clear; echo "$i SendString"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/sendString/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/sendString/client.ldgvnw & wait); + clear; echo "$i TwoCons"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/twoCons/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/twoCons/client.ldgvnw & wait); clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/simple/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/simple/client.ldgvnw & wait); clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirectional/client.ldgvnw & wait); clear; echo "$i Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/client.ldgvnw & wait); diff --git a/networking-tests/testOftenTwoCons.sh b/networking-tests/testOftenTwoCons.sh new file mode 100644 index 0000000..c99e2b1 --- /dev/null +++ b/networking-tests/testOftenTwoCons.sh @@ -0,0 +1,3 @@ +for i in {1..2000}; do + clear; echo "$i TwoCons"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/twoCons/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/twoCons/client.ldgvnw & wait); +done \ No newline at end of file From e0bdaaec44d0fda33679fdac39c8dde988ee5b2a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Mon, 13 Mar 2023 18:26:02 +0100 Subject: [PATCH 218/229] Update README-networking.md --- README-networking.md | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/README-networking.md b/README-networking.md index 26f841e..04fa832 100644 --- a/README-networking.md +++ b/README-networking.md @@ -20,9 +20,9 @@ LDGVNW adds two new commands to LDGV to allow for networking capabilities: - `connect ` The accept command requires an integer as a port for others to connect and a type that will be required of a connecting connection. -Once a communication partner connects with a desired type, the accept command will return a VChan. +Once a communication partner connects with a desired type, the accept command will return a VChan, of the desired type. The connect command also requires an integer port and a desired type, but also needs to specify a string for the address of the connection partner as well as an integer for the port of the connection partner. -Just like with the accept command, the connect command will return a VChan, once a connection has been established. +Just like with the accept command, the connect command will return a VChan, of the desired type, once a connection has been established. Important to note is that, with the current implementation, only IPv4 addresses are supported. IPv6 and Unix domain sockets could be supported in the future with a relatively low effort. @@ -70,7 +70,7 @@ Should V be or contain a Channel C, A will set a flag in C to redirect new messa After that, C will be converted to a serializable form, CS. With every Channel now being in a form which can be sent over the network, A now writes V to its write-buffer and sends B a NewValue message containing V. Upon receiving V as B with the recv instruction, B now undoes the conversion of every Channel in V. -B then contacts the communication partner of each Channel, to inform them that their new communication partner is now B instead of A. +B then contacts the communication partner of each Channel, to inform them, that their new communication partner is now B, instead of A. After this, B sends an acknowledgment (AcknowledgeValue message) back to A, which finalizes the sending of V. A can now remove V out of its write-buffer. @@ -91,14 +91,14 @@ B then replies with a AcknowledgePartnerAddress message, repeating DC. As soon as the address is established, C is considered successfully received by D. ## Shutting down after completing all the instructions -After A finishes the interpretation of their program, A waits until all messages it sent were acknowledged by their communication partners. After that, A sends a Disconnect message to all its peers. The Disconnect message is needed to avoid rewriting a large portion of the interpreter to annotate each recv expression with their associated output Types. Should the Disconnect message not exist, it would be theoretically possible to send a Unit-Type of an exhausted Channel to another communication partner. The recipient would now be unknowing whether their new communication partner were still online. +After A finishes the interpretation of their program, A waits until all messages it sent were acknowledged by their communication partners. After that, A sends a Disconnect message to all their peers. The Disconnect message is needed to avoid rewriting a large portion of the interpreter to annotate each recv expression with their associated output Types. Should the Disconnect message not exist, it would be theoretically possible to send a Unit-Type of an exhausted Channel to another communication partner. The recipient would now be unknowing whether their new communication partner were still online. ## Making Channels serializable -One of the main focuses of LDGVNW was to send Channels over the network. +One of the main focuses of LDGVNW is to send Channels over the network. VChans are Channels that are directly useable by LDGV, but since VChans can't be serialized directly, they need to be converted into VChanSerials first. VChans have the following (simplified) architecture: `VChan ` -The contained NetworkConnection has this architecture: +The contained NetworkConnection has this (simplified) architecture: `NetworkConnection ` @@ -132,7 +132,7 @@ Messages and Responses in LDGVNW are serialized into ASCII-Strings and follow th To deserialize these messages, the alex and happy libraries are used. ## Stateless Protocol -The stateless protocol allows sending serialized logical messages directly, by establishing a new connection, sending the serialized message, waiting for a response and disconnecting afterward. By always creating new connections, it can be assured that every message gets its correct response, but establishing a new TCP connection every time a message is sent, also causes a performance penalty. The stateless protocol creates a new temporary thread to handle each incoming message. Messages are primarily sent from the main thread, in which also the interpretation occurs, except for some messages like the acknowledging of a new partner address, which is sent from the temporary thread. +The stateless protocol allows sending serialized logical messages directly. A new connection is established, followed by, sending the serialized message, waiting for a response and disconnecting afterward. Always creating new connections assures that every message gets its correct response, but establishing a new TCP connection every time a message is sent, also causes a performance penalty. The stateless protocol has a thread permanently looking for new messages. This thread creates a new temporary thread to handle each incoming message. Messages are primarily sent from the main thread, in which also the interpretation occurs, except for some messages like the acknowledging of a new partner address, which is sent from the temporary thread. ## Fast Protocol The fast protocol saves a once created TCP connection and reuses it as long as it stays open. Since LDGVNW uses multiple threads to send messages, this can lead to messages and responses being mismatched. To avoid this, each Message and Response is wrapped in a ConversationSession. @@ -141,13 +141,14 @@ The fast protocol saves a once created TCP connection and reuses it as long as i - `ConversationResponse ` - `ConversationCloseAll` -The ConversationID is a random string, selected by the sender of the message and copied by the respondent. ConversationCloseAll is used when one party wants to close all connections to a peer, signaling to their peer that they would need to establish a new connection if they would like to talk to this address and port again. +The ConversationID is a random string, selected by the sender of the message and copied by the respondent. ConversationCloseAll is used when one party wants to close all connections to a peer, signaling to their peer that they would need to establish a new connection, if they would like to talk to this address and port again. This is helpful if there are A and B. A has an address and port combination of AP. After A and B are done communicating, A goes offline and sends an ConversationCloseAll. Now, C can reuse AP to talk to B. -Each TCP connection gets its own thread, where new incoming messages and responses are collected. Each Channel also gets its own thread, where incoming messages get handled. Responses can be picked up by the sending function, to determine its further behavior. +The fast protocol also has a permanent thread, looking for new incoming connections. Each new TCP connection gets its own permanent thread, where new incoming messages and responses are collected. Each Channel also gets its own thread, where incoming messages get handled. Responses can be picked up by the sending function, to determine its further behavior. Similar to the stateless protocol, most messages are sent from the main thread, while some messages are sent from a connection specific thread. # Compatibility between Internal and External Channels -Internal Channels (Channels in the same program, created with new) and external Channels (Channels between two programs, created with connect and accept) are handled, for the most part, the same way in LDGVNW. Every Channel has a NetworkConnection object. The NetworkConnection object saves both incoming and outgoing messages and a ConnectionState. The ConnectionState object dictates whether a NetworkConnection is internal or external. +Internal Channels (Channels in the same program, typically created with new) and external Channels (Channels between two programs, typically created with connect and accept) are handled, for the most part, the same way in LDGVNW. Every Channel has a NetworkConnection object. The NetworkConnection object saves both incoming and outgoing messages and a ConnectionState. The ConnectionState object dictates whether a NetworkConnection is internal or external. In contrast to external Channels, which serialize and send messages, internal Channels write the data of these messages directly to their counterparts. Should an internal Channel be sent to a peer, the internal Channel gets converted into an external Channel. Should both sides of an external Channel end up in the same program, the connection will be converted to an internal Channel. + From 06cbc87a2489cb2ea9947e3654c05ef9a68fbab3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 14 Mar 2023 13:45:21 +0100 Subject: [PATCH 219/229] Allow to detect a local connection when connecting --- networking-examples/add2/add.ldgvnw | 29 +++++++++++++++++++++++++++++ networking-tests/testNWCount.sh | 1 + networking-tests/testNWCountHigh.sh | 1 + networking-tests/testOftenAdd2.sh | 3 +++ src/Networking/Outgoing.hs | 23 +++++++++++++++++++++-- 5 files changed, 55 insertions(+), 2 deletions(-) create mode 100644 networking-examples/add2/add.ldgvnw create mode 100644 networking-tests/testOftenAdd2.sh diff --git a/networking-examples/add2/add.ldgvnw b/networking-examples/add2/add.ldgvnw new file mode 100644 index 0000000..0df57b2 --- /dev/null +++ b/networking-examples/add2/add.ldgvnw @@ -0,0 +1,29 @@ +-- Simple example of Label-Dependent Session Types +-- Interprets addition of two numbers + +type SendInt : ! ~ssn = !Int. !Int. Unit + +val send2 (c: SendInt) = + let x = ((send c) 1) in + let y = ((send x) 42) in + () + +val add2 (c1: dualof SendInt) = + let = recv c1 in + let = recv c2 in + (m + n) + +val addClient : Unit +val addClient = + let con = connect 4242 SendInt "127.0.0.1" 4242 in + send2 con + +val addServer : Int +val addServer = + let con = accept 4242 (dualof SendInt) in + add2 con + +val main : Int +val main = + let c = fork addClient in + addServer diff --git a/networking-tests/testNWCount.sh b/networking-tests/testNWCount.sh index a14ce4a..8461e86 100644 --- a/networking-tests/testNWCount.sh +++ b/networking-tests/testNWCount.sh @@ -2,6 +2,7 @@ for i in {1..10}; do clear; echo "$i Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/add/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/add/client.ldgvnw & wait); clear; echo "$i SendString"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/sendString/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/sendString/client.ldgvnw & wait); clear; echo "$i TwoCons"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/twoCons/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/twoCons/client.ldgvnw & wait); + clear; echo "$i Add2"; stack run ldgv -- interpret ../networking-examples/add2/add.ldgvnw clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/simple/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/simple/client.ldgvnw & wait); clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirectional/client.ldgvnw & wait); clear; echo "$i Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/client.ldgvnw & wait); diff --git a/networking-tests/testNWCountHigh.sh b/networking-tests/testNWCountHigh.sh index abb9496..be538bd 100644 --- a/networking-tests/testNWCountHigh.sh +++ b/networking-tests/testNWCountHigh.sh @@ -2,6 +2,7 @@ for i in {1..20000}; do clear; echo "$i Add"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/add/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/add/client.ldgvnw & wait); clear; echo "$i SendString"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/sendString/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/sendString/client.ldgvnw & wait); clear; echo "$i TwoCons"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/twoCons/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/twoCons/client.ldgvnw & wait); + clear; echo "$i Add2"; stack run ldgv -- interpret ../networking-examples/add2/add.ldgvnw clear; echo "$i Simple"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/simple/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/simple/client.ldgvnw & wait); clear; echo "$i Bidirectional"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/bidirectional/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/bidirectional/client.ldgvnw & wait); clear; echo "$i Handoff"; (trap 'kill 0' SIGINT; stack run ldgv -- interpret < ../networking-examples/handoff/server.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/handoff.ldgvnw & stack run ldgv -- interpret < ../networking-examples/handoff/client.ldgvnw & wait); diff --git a/networking-tests/testOftenAdd2.sh b/networking-tests/testOftenAdd2.sh new file mode 100644 index 0000000..1fbfcd0 --- /dev/null +++ b/networking-tests/testOftenAdd2.sh @@ -0,0 +1,3 @@ +for i in {1..2000}; do + clear; echo "$i Add2"; stack run ldgv -- interpret ../networking-examples/add2/add.ldgvnw +done \ No newline at end of file diff --git a/src/Networking/Outgoing.hs b/src/Networking/Outgoing.hs index 4c04562..7eb6d31 100644 --- a/src/Networking/Outgoing.hs +++ b/src/Networking/Outgoing.hs @@ -44,6 +44,7 @@ sendValue vchanconsmvar activeCons networkconnection val ownport resendOnError = let mbypartner = Map.lookup ownid vchancons case mbypartner of Just partner -> do + Config.traceNetIO $ "Emulated Send for: " ++ NSerialize.serialize valCleaned NB.write (ncRead partner) valCleaned return True _ -> do @@ -172,8 +173,26 @@ initialConnect activeCons mvar hostname port ownport syntype= do Config.traceNetIO $ " Message: " ++ msgserial newConnection <- newNetworkConnection introductionanswer ownuserid hostname port introductionanswer ownuserid networkconnectionmap <- MVar.takeMVar mvar - let newNetworkconnectionmap = Map.insert introductionanswer newConnection networkconnectionmap - MVar.putMVar mvar newNetworkconnectionmap + -- Look whether partner is already registered locally + case Map.lookup ownuserid networkconnectionmap of + Just partner -> SSem.withSem (ncHandlingIncomingMessage partner) do + connectionstate <- MVar.takeMVar $ ncConnectionState partner + case connectionstate of + Connected {} -> do + partConID <- RandomID.newRandomID + ownConID <- RandomID.newRandomID + MVar.putMVar (ncConnectionState partner) $ Emulated ownConID partConID True + MVar.takeMVar $ ncConnectionState newConnection + MVar.putMVar (ncConnectionState newConnection) $ Emulated partConID ownConID True + let newNetworkconnectionmap = Map.insert introductionanswer newConnection networkconnectionmap + MVar.putMVar mvar newNetworkconnectionmap + _ -> do + MVar.putMVar (ncConnectionState partner) connectionstate + let newNetworkconnectionmap = Map.insert introductionanswer newConnection networkconnectionmap + MVar.putMVar mvar newNetworkconnectionmap + Nothing -> do + let newNetworkconnectionmap = Map.insert introductionanswer newConnection networkconnectionmap + MVar.putMVar mvar newNetworkconnectionmap used <- MVar.newEmptyMVar MVar.putMVar used False return $ VChan newConnection used From 2ed96e1bd45feeb348355a603eed101fa4151c7b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 14 Mar 2023 15:14:35 +0100 Subject: [PATCH 220/229] Reduced code duplication --- src/Networking/Incoming.hs | 8 ++++++++ src/Networking/NetworkConnection.hs | 24 +++++++++++++++++++++++- src/Networking/Outgoing.hs | 28 ++++++++-------------------- 3 files changed, 39 insertions(+), 21 deletions(-) diff --git a/src/Networking/Incoming.hs b/src/Networking/Incoming.hs index 6612686..eb1f328 100644 --- a/src/Networking/Incoming.hs +++ b/src/Networking/Incoming.hs @@ -169,6 +169,7 @@ contactNewPeers vchansmvar activeCons ownport ownNC = searchVChans (handleVChan _ -> do if csConfirmedConnection connectionState then return True else do -- Check whether their partner is also registered and connected on this instance, if so convert the connection into a emulated one + {- vchanconnections <- MVar.readMVar vchansmvar let userid = ncOwnUserID nc let mbypartner = Map.lookup userid vchanconnections @@ -201,6 +202,13 @@ contactNewPeers vchansmvar activeCons ownport ownNC = searchVChans (handleVChan if sendSuccess then return False else do threadDelay 100000 return False + -} + success <- NCon.tryConvertToEmulatedConnection vchansmvar nc + unless success $ do + sendSuccess <- NO.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) $ -2 + unless sendSuccess $ threadDelay 100000 + return success + _ -> return True hostaddressTypeToString :: HostAddress -> String diff --git a/src/Networking/NetworkConnection.hs b/src/Networking/NetworkConnection.hs index e4fd163..0c93c21 100644 --- a/src/Networking/NetworkConnection.hs +++ b/src/Networking/NetworkConnection.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} module Networking.NetworkConnection where import Networking.NetworkBuffer @@ -117,5 +118,26 @@ confirmConnectionID con ownConnectionID = do MVar.putMVar (ncConnectionState con) conState return False - +tryConvertToEmulatedConnection :: MVar.MVar (Map.Map String (NetworkConnection a)) -> NetworkConnection a -> IO Bool +tryConvertToEmulatedConnection vchans con = do + -- networkConnectionsMap <- MVar.takeMVar vchans + networkConnectionsMap <- MVar.readMVar vchans + case Map.lookup (ncOwnUserID con) networkConnectionsMap of + Just partner -> SSem.withSem (ncHandlingIncomingMessage partner) do + connectionState <- MVar.takeMVar $ ncConnectionState partner + case connectionState of + Connected {} -> do + partConID <- newRandomID + ownConID <- newRandomID + MVar.putMVar (ncConnectionState partner) $ Emulated ownConID partConID True + MVar.takeMVar $ ncConnectionState con + MVar.putMVar (ncConnectionState con) $ Emulated partConID ownConID True + -- MVar.putMVar vchans networkConnectionsMap + return True + _ -> do + -- MVar.putMVar vchans networkConnectionsMap + return False + _ -> do + -- MVar.putMVar vchans networkConnectionsMap + return False diff --git a/src/Networking/Outgoing.hs b/src/Networking/Outgoing.hs index 7eb6d31..14047d4 100644 --- a/src/Networking/Outgoing.hs +++ b/src/Networking/Outgoing.hs @@ -172,27 +172,15 @@ initialConnect activeCons mvar hostname port ownport syntype= do Config.traceNetIO $ " Over: " ++ hostname ++ ":" ++ port Config.traceNetIO $ " Message: " ++ msgserial newConnection <- newNetworkConnection introductionanswer ownuserid hostname port introductionanswer ownuserid + networkconnectionmap <- MVar.takeMVar mvar - -- Look whether partner is already registered locally - case Map.lookup ownuserid networkconnectionmap of - Just partner -> SSem.withSem (ncHandlingIncomingMessage partner) do - connectionstate <- MVar.takeMVar $ ncConnectionState partner - case connectionstate of - Connected {} -> do - partConID <- RandomID.newRandomID - ownConID <- RandomID.newRandomID - MVar.putMVar (ncConnectionState partner) $ Emulated ownConID partConID True - MVar.takeMVar $ ncConnectionState newConnection - MVar.putMVar (ncConnectionState newConnection) $ Emulated partConID ownConID True - let newNetworkconnectionmap = Map.insert introductionanswer newConnection networkconnectionmap - MVar.putMVar mvar newNetworkconnectionmap - _ -> do - MVar.putMVar (ncConnectionState partner) connectionstate - let newNetworkconnectionmap = Map.insert introductionanswer newConnection networkconnectionmap - MVar.putMVar mvar newNetworkconnectionmap - Nothing -> do - let newNetworkconnectionmap = Map.insert introductionanswer newConnection networkconnectionmap - MVar.putMVar mvar newNetworkconnectionmap + let newNetworkconnectionmap = Map.insert introductionanswer newConnection networkconnectionmap + MVar.putMVar mvar newNetworkconnectionmap + + -- If it can be converted to local do that + NCon.tryConvertToEmulatedConnection mvar newConnection + + used <- MVar.newEmptyMVar MVar.putMVar used False return $ VChan newConnection used From 68e8f9e443cec20662c17846707208dc10d02edb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 14 Mar 2023 16:33:02 +0100 Subject: [PATCH 221/229] Improved readme --- README-networking.md | 43 +++++++++++++++++++------------------- src/Networking/Incoming.hs | 34 ------------------------------ 2 files changed, 22 insertions(+), 55 deletions(-) diff --git a/README-networking.md b/README-networking.md index 04fa832..ca01a01 100644 --- a/README-networking.md +++ b/README-networking.md @@ -19,9 +19,9 @@ LDGVNW adds two new commands to LDGV to allow for networking capabilities: - `accept ` - `connect ` -The accept command requires an integer as a port for others to connect and a type that will be required of a connecting connection. -Once a communication partner connects with a desired type, the accept command will return a VChan, of the desired type. -The connect command also requires an integer port and a desired type, but also needs to specify a string for the address of the connection partner as well as an integer for the port of the connection partner. +The accept command requires an integer as a port, for others to connect, and a type, that will be required of a connecting connection. +Once a communication partner connects with a desired type, the accept command will return a VChan, of this type. +The connect command also requires an integer port and a desired type, but also needs to specify a string, for the address of the connection partner, and an integer, for the port of the connection partner. Just like with the accept command, the connect command will return a VChan, of the desired type, once a connection has been established. Important to note is that, with the current implementation, only IPv4 addresses are supported. IPv6 and Unix domain sockets could be supported in the future with a relatively low effort. @@ -50,13 +50,13 @@ With possible responses: Typing for the attributes: - **UserID** is a unique string, used to identify the logical communication partner -- **ConnectionID** is a unique string, used to identify the current physical connection to a logical communication partner -- **Port** is a string containing the number of a port -- **Address** is a string containing the IPv4 address or URL of a communication partner +- **ConnectionID** is a unique string, used to identify the current physical connection, to a logical communication partner +- **Port** is a string, containing the port number +- **Address** is a string, containing the IPv4 address or URL of a communication partner - **Value** is a type of data in LDGV. The VChans present in this Value are replaced with VChanSerials -- **Value Index** is an integer containing the index of a Value -- **Type Name** is a TName Type of the desired Type -- **Type Structure** of the desired Type +- **Value Index** is an integer, containing the index of a Value +- **Type Name** is a TName Type, of the desired Type +- **Type Structure** is a Type, containing the resolved Type of the Type Name ## Establishing a new Connection As soon as B opens up their port with the accept command. A can connect, by sending an Introduce message to B. @@ -65,11 +65,11 @@ B then answers with a OkayIntroduce response, sharing their own unique ID with A Following that, A and B can send and recv values analog to Channels created with the new command. ## Sending messages over a Connection -When communication partner A executes a send instruction to send Value V to B, A first analyses V. +When communication partner A executes a send command to send Value V to B, A first analyses V. Should V be or contain a Channel C, A will set a flag in C to redirect new messages to the address of B. After that, C will be converted to a serializable form, CS. -With every Channel now being in a form which can be sent over the network, A now writes V to its write-buffer and sends B a NewValue message containing V. -Upon receiving V as B with the recv instruction, B now undoes the conversion of every Channel in V. +With every Channel now being in a form, which can be sent over the network, A writes V to its write-buffer and sends B a NewValue message containing V. +Upon receiving V as B with the recv command, B undoes the conversion of every Channel in V. B then contacts the communication partner of each Channel, to inform them, that their new communication partner is now B, instead of A. After this, B sends an acknowledgment (AcknowledgeValue message) back to A, which finalizes the sending of V. A can now remove V out of its write-buffer. @@ -77,21 +77,21 @@ A can now remove V out of its write-buffer. ## Responding to Messages Except for the Introduce message, every message should be ideally answered with an Okay response. But in some cases the messages don't arrive at the right communication partner or at the wrong time. In these cases, other responses are used. -- **Redirect** responses are sent when a message is sent to an outdated address -- **Wait** responses are sent when a message cannot be handled at the current moment +- **Redirect** responses are sent, when a message is sent to an outdated address +- **Wait** responses are sent, when a message cannot be handled at the current moment - This can be caused by currently being in a critical section while handling another message - During the sending process of a Channel - When the addressed Channel isn't yet known by the program - **Error** responses are sent when an error occurs while handling a AcknowledgePartnerAddress message -## Informing communication partners of a communication partner change +## Informing Communication Partners of a Communication Partner Change If there is a Channel C between A and B and A sends their side of the Channel to D, B needs to be made aware of that. To archive this, D sends a NewPartnerAddress message to B. This message contains the server port of D and a new ConnectionID DC for D. B then replies with a AcknowledgePartnerAddress message, repeating DC. As soon as the address is established, C is considered successfully received by D. -## Shutting down after completing all the instructions -After A finishes the interpretation of their program, A waits until all messages it sent were acknowledged by their communication partners. After that, A sends a Disconnect message to all their peers. The Disconnect message is needed to avoid rewriting a large portion of the interpreter to annotate each recv expression with their associated output Types. Should the Disconnect message not exist, it would be theoretically possible to send a Unit-Type of an exhausted Channel to another communication partner. The recipient would now be unknowing whether their new communication partner were still online. +## Shutting Down after Completing all Instructions +After A finishes the interpretation of their program, A waits until all messages they sent were acknowledged by their communication partners. After that, A sends a Disconnect message to all their peers. The Disconnect message is needed, since the recv command doesn't know the received Type during interpretation. Should the Disconnect message not exist, it would be theoretically possible to send a Unit-Type of an exhausted Channel to another communication partner. The recipient would now be unknowing whether their new communication partner is still online. ## Making Channels serializable One of the main focuses of LDGVNW is to send Channels over the network. @@ -116,15 +116,15 @@ It is important to note that VChans only should be serialized after their Connec ## Why Values are Acknowledged LDGVNW has separate messages for sending a Value (NewValue) and acknowledging a Value (AcknowledgeValue). Simply knowing that the other party has received a Value, isn't enough when Channels are involved. -Let's say there is a Channel C, between A and B. A sends their end of C to D and at the same time, B sends their end of C to E. Since the sending of the Channel ends, happened simultaneously, D still thinks they are talking to B and E thinks they are talking to A. Should A and B now go offline, before either D or E, can contact them to find out where they redirected their connections to, D and E will not be able to connect. Since acknowledgments are only sent after a sent Channel has been reconnected, it can be assured that D and E are connected, before A and B can go offline. +Let's say there is a Channel C, between A and B. A sends their side of C to D and at the same time, B sends their side of C to E. Since the sending of the Channel sides, happened simultaneously, D still thinks they are talking to B and E thinks they are talking to A. Should A and B now go offline, before either D or E, can contact them, to find out where they redirected their connections to, D and E will not be able to connect. Since acknowledgments are only sent after a sent Channel has been reconnected, it can be assured that D and E are connected, before A and B can go offline. It would also be possible to use a Response to the NewValue message, to signal that the Value got acknowledged, but I decided to split this process into two messages, since the acknowledging can take long time, compared to other messages. ## A communication example -The [communication example](README-networking-communication-example.md) gives a concrete example of the communication protocol. +The [communication example](README-networking-communication-example.md) gives a concrete demonstration of the communication protocol. # Serializing and Sending Messages -The logical messages are serialized first, then are sent either using a fast protocol, which reuses existing connections or a stateless protocol, which was primary used during development as a fallback when the fast protocol wasn't working yet. +The logical messages are serialized first, then are sent either using a fast protocol, which reuses existing connections or a stateless protocol, which was primary used during development, as a fallback when the fast protocol wasn't working yet. ## Serialization Messages and Responses in LDGVNW are serialized into ASCII-Strings and follow the form of the name of the Message, Value, etc. followed by their arguments in brackets. For instance, the message `NewValue <2> ` would be translated to `NNewValue (String:"abcd1234") (Int:2) (VInt (Int:42))` @@ -142,7 +142,7 @@ The fast protocol saves a once created TCP connection and reuses it as long as i - `ConversationCloseAll` The ConversationID is a random string, selected by the sender of the message and copied by the respondent. ConversationCloseAll is used when one party wants to close all connections to a peer, signaling to their peer that they would need to establish a new connection, if they would like to talk to this address and port again. -This is helpful if there are A and B. A has an address and port combination of AP. After A and B are done communicating, A goes offline and sends an ConversationCloseAll. Now, C can reuse AP to talk to B. +This is helpful if there are A and B. A has an address and port combination of AP. After A and B are done communicating, A goes offline and sends a ConversationCloseAll. Now, C can reuse AP to talk to B. The fast protocol also has a permanent thread, looking for new incoming connections. Each new TCP connection gets its own permanent thread, where new incoming messages and responses are collected. Each Channel also gets its own thread, where incoming messages get handled. Responses can be picked up by the sending function, to determine its further behavior. Similar to the stateless protocol, most messages are sent from the main thread, while some messages are sent from a connection specific thread. @@ -152,3 +152,4 @@ In contrast to external Channels, which serialize and send messages, internal Ch Should an internal Channel be sent to a peer, the internal Channel gets converted into an external Channel. Should both sides of an external Channel end up in the same program, the connection will be converted to an internal Channel. + diff --git a/src/Networking/Incoming.hs b/src/Networking/Incoming.hs index eb1f328..4732bac 100644 --- a/src/Networking/Incoming.hs +++ b/src/Networking/Incoming.hs @@ -169,40 +169,6 @@ contactNewPeers vchansmvar activeCons ownport ownNC = searchVChans (handleVChan _ -> do if csConfirmedConnection connectionState then return True else do -- Check whether their partner is also registered and connected on this instance, if so convert the connection into a emulated one - {- - vchanconnections <- MVar.readMVar vchansmvar - let userid = ncOwnUserID nc - let mbypartner = Map.lookup userid vchanconnections - case mbypartner of - Just partner -> do - -- Their partner is registered in this instance. Now we have to figure out whether this is till current and we can start emulating the connection - SSem.wait (ncHandlingIncomingMessage partner) - connectionstate <- MVar.takeMVar $ ncConnectionState partner - case connectionState of - Connected {} -> do - -- Reemulate them - partConID <- RandomID.newRandomID - ownConID <- RandomID.newRandomID - MVar.putMVar (ncConnectionState partner) $ Emulated ownConID partConID True - _ <- MVar.takeMVar $ ncConnectionState nc - MVar.putMVar (ncConnectionState nc) $ Emulated partConID ownConID True - SSem.signal (ncHandlingIncomingMessage partner) - return True - _ -> do - -- Nothing to do here, we no longer own the partner - MVar.putMVar (ncConnectionState partner) connectionState - SSem.signal (ncHandlingIncomingMessage partner) - sendSuccess <- NO.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) $ -2 - if sendSuccess then return False else do - threadDelay 100000 - return False - Nothing -> do - -- Their partner isnt registered in this instance - sendSuccess <- NO.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) $ -2 - if sendSuccess then return False else do - threadDelay 100000 - return False - -} success <- NCon.tryConvertToEmulatedConnection vchansmvar nc unless success $ do sendSuccess <- NO.sendNetworkMessage activeCons nc (Messages.NewPartnerAddress (ncOwnUserID nc) ownport $ csOwnConnectionID connectionState) $ -2 From b725294ea46e742d4e62b3c298183f723f3b96a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 14 Mar 2023 18:46:10 +0100 Subject: [PATCH 222/229] Added me to the contributers --- README-networking.md | 10 +++++----- exe/Main.hs | 1 + 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/README-networking.md b/README-networking.md index ca01a01..3df217c 100644 --- a/README-networking.md +++ b/README-networking.md @@ -19,7 +19,7 @@ LDGVNW adds two new commands to LDGV to allow for networking capabilities: - `accept ` - `connect ` -The accept command requires an integer as a port, for others to connect, and a type, that will be required of a connecting connection. +The accept command requires an integer, as a port for others to connect, and a type, that will be required of a connecting connection. Once a communication partner connects with a desired type, the accept command will return a VChan, of this type. The connect command also requires an integer port and a desired type, but also needs to specify a string, for the address of the connection partner, and an integer, for the port of the connection partner. Just like with the accept command, the connect command will return a VChan, of the desired type, once a connection has been established. @@ -110,7 +110,7 @@ The VChanSerial has the following architecture: The ReadList contains the current elements of the ReadBuffer, the ReadOffset contains the logical index of the first element of the ReadBuffer, and the ReadLength is the number of all logical elements in the buffer. For example, let's say 5 Values were received, but the first 3 already were handled, so the ReadList would contain 2 elements, the ReadOffset would be 3 and the ReadLength would be 5. The WriteList, WriteOffset and WriteLength behave analogously. The PartnerID and OwnID are directly taken from the NetworkConnection and the Address, Port and ConnectionID (from the partner) are taken from the ConnectionState. -To convert a VChanSerial to a VChan an empty VChan is simply filled with the data provided by the VChanSerial. +To convert a VChanSerial to a VChan, an empty VChan is simply filled with the data provided by the VChanSerial. It is important to note that VChans only should be serialized after their ConnectionState has been set to Redirect. This freezes the VChan, as it can no longer receive new messages. This way it can be assured, that at the time of receipt, both the original VChan and the one generated from the VChanSerial contain identical data. @@ -124,10 +124,10 @@ It would also be possible to use a Response to the NewValue message, to signal t The [communication example](README-networking-communication-example.md) gives a concrete demonstration of the communication protocol. # Serializing and Sending Messages -The logical messages are serialized first, then are sent either using a fast protocol, which reuses existing connections or a stateless protocol, which was primary used during development, as a fallback when the fast protocol wasn't working yet. +The logical messages are serialized first, then are sent either using a fast protocol, which reuses existing connections or a stateless protocol, which was primary used during development, as a fallback when the fast protocol wasn't working yet. The fast protocol is enabled by default, switching protocols requires a small change to the networking code. ## Serialization -Messages and Responses in LDGVNW are serialized into ASCII-Strings and follow the form of the name of the Message, Value, etc. followed by their arguments in brackets. For instance, the message `NewValue <2> ` would be translated to `NNewValue (String:"abcd1234") (Int:2) (VInt (Int:42))` +Messages and Responses in LDGVNW are serialized into ASCII-Strings and follow the form of the name of the Message, Value, etc. followed by their arguments in parentheses. For instance, the message `NewValue <2> ` would be translated to `NNewValue (String:"abcd1234") (Int:2) (VInt (Int:42))` To deserialize these messages, the alex and happy libraries are used. @@ -147,7 +147,7 @@ The fast protocol also has a permanent thread, looking for new incoming connecti Similar to the stateless protocol, most messages are sent from the main thread, while some messages are sent from a connection specific thread. # Compatibility between Internal and External Channels -Internal Channels (Channels in the same program, typically created with new) and external Channels (Channels between two programs, typically created with connect and accept) are handled, for the most part, the same way in LDGVNW. Every Channel has a NetworkConnection object. The NetworkConnection object saves both incoming and outgoing messages and a ConnectionState. The ConnectionState object dictates whether a NetworkConnection is internal or external. +Internal Channels (Channels in the same program, typically created with new) and external Channels (Channels between two programs, typically created with connect and accept) are handled, for the most part, the same way in LDGVNW. Every Channel has a NetworkConnection. The NetworkConnection saves both incoming and outgoing messages and a ConnectionState. The ConnectionState dictates whether a NetworkConnection is internal or external. In contrast to external Channels, which serialize and send messages, internal Channels write the data of these messages directly to their counterparts. Should an internal Channel be sent to a peer, the internal Channel gets converted into an external Channel. Should both sides of an external Channel end up in the same program, the connection will be converted to an internal Channel. diff --git a/exe/Main.hs b/exe/Main.hs index 91cf169..692a9f5 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -162,6 +162,7 @@ actionParserInfo = Opts.info (actionParser <**> Opts.helper) $ mconcat , Opts.footer "Authors: \ \Thomas Leyh (CCLDLC implementation), \ \Nils Hagner (interpreter, web frontend), \ + \L. Läufer (networking extension for LDGV), \ \Janek Spaderna (C backend, command line frontend), \ \Peter Thiemann (parser, typechecker)" ] From a4215713a940779f89cbed3e49cc69acc557c42f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 15 Mar 2023 10:09:50 +0100 Subject: [PATCH 223/229] Update README-networking.md --- README-networking.md | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/README-networking.md b/README-networking.md index 3df217c..5ca4cd6 100644 --- a/README-networking.md +++ b/README-networking.md @@ -24,7 +24,7 @@ Once a communication partner connects with a desired type, the accept command wi The connect command also requires an integer port and a desired type, but also needs to specify a string, for the address of the connection partner, and an integer, for the port of the connection partner. Just like with the accept command, the connect command will return a VChan, of the desired type, once a connection has been established. Important to note is that, with the current implementation, only IPv4 addresses are supported. -IPv6 and Unix domain sockets could be supported in the future with a relatively low effort. +IPv6 and Unix domain sockets could be supported in the future, with relatively low effort. # The Logical Communication Architecture ## Messages and Responses @@ -127,12 +127,12 @@ The [communication example](README-networking-communication-example.md) gives a The logical messages are serialized first, then are sent either using a fast protocol, which reuses existing connections or a stateless protocol, which was primary used during development, as a fallback when the fast protocol wasn't working yet. The fast protocol is enabled by default, switching protocols requires a small change to the networking code. ## Serialization -Messages and Responses in LDGVNW are serialized into ASCII-Strings and follow the form of the name of the Message, Value, etc. followed by their arguments in parentheses. For instance, the message `NewValue <2> ` would be translated to `NNewValue (String:"abcd1234") (Int:2) (VInt (Int:42))` +Messages and Responses in LDGVNW are serialized into ASCII-Strings and follow the form of the name of the Message, Value, etc. followed by their arguments in parentheses. For instance, the message `NewValue <2> ` would be translated to `NNewValue (String:"abcd1234") (Int:2) (VInt (Int:42))`. The N in front of NewValue, signals that it belongs to the networking messages, the V in front of Int makes differentiating between Value Ints and other Ints easier. To deserialize these messages, the alex and happy libraries are used. ## Stateless Protocol -The stateless protocol allows sending serialized logical messages directly. A new connection is established, followed by, sending the serialized message, waiting for a response and disconnecting afterward. Always creating new connections assures that every message gets its correct response, but establishing a new TCP connection every time a message is sent, also causes a performance penalty. The stateless protocol has a thread permanently looking for new messages. This thread creates a new temporary thread to handle each incoming message. Messages are primarily sent from the main thread, in which also the interpretation occurs, except for some messages like the acknowledging of a new partner address, which is sent from the temporary thread. +The stateless protocol allows sending serialized logical messages directly. A new connection is established, followed by, sending the serialized message, waiting for a response and disconnecting afterward. Always creating new connections assures that every message gets its correct response, but establishing a new TCP connection every time a message is sent, also causes a performance penalty. The stateless protocol has a thread permanently looking for new messages. This thread creates a new temporary thread to handle each incoming message. Messages are primarily sent from the main thread, in which also the interpretation occurs, except for some messages, like the acknowledging of a new partner address, which is sent from the temporary thread. ## Fast Protocol The fast protocol saves a once created TCP connection and reuses it as long as it stays open. Since LDGVNW uses multiple threads to send messages, this can lead to messages and responses being mismatched. To avoid this, each Message and Response is wrapped in a ConversationSession. @@ -153,3 +153,4 @@ Should an internal Channel be sent to a peer, the internal Channel gets converte + From 79b8ccce07b8b3b228bb2d1d493c865561c288c6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Leon=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Wed, 15 Mar 2023 18:20:04 +0100 Subject: [PATCH 224/229] Update README-networking.md --- README-networking.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/README-networking.md b/README-networking.md index 5ca4cd6..9161056 100644 --- a/README-networking.md +++ b/README-networking.md @@ -120,6 +120,9 @@ Let's say there is a Channel C, between A and B. A sends their side of C to D an It would also be possible to use a Response to the NewValue message, to signal that the Value got acknowledged, but I decided to split this process into two messages, since the acknowledging can take long time, compared to other messages. +## Requesting a Value +Sending of most messages is only attempted once, this includes NewValue messages. A Value can be requested, by the recv command, using a RequestValue message. + ## A communication example The [communication example](README-networking-communication-example.md) gives a concrete demonstration of the communication protocol. From d0f31c267a5580b15bfe765aa45cc5d58a4136dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=2E=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Thu, 25 May 2023 07:24:37 +0200 Subject: [PATCH 225/229] Bump resolver, to fix compilation on M1 Macs --- src/Networking/Serialize.hs | 6 +++--- stack.yaml | 5 +++-- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Networking/Serialize.hs b/src/Networking/Serialize.hs index 0993061..687c5e1 100644 --- a/src/Networking/Serialize.hs +++ b/src/Networking/Serialize.hs @@ -181,13 +181,13 @@ instance Serializable Bool where instance Serializable Double where serialize d = "Double:" ++ show d -instance ((Serializable a, Serializable b) => Serializable (a, b)) where +instance (Serializable a, Serializable b) => Serializable (a, b) where serialize (s, t) = "((" ++ serialize s++ ") (" ++ serialize t ++ "))" -instance ((Serializable a, Serializable b, Serializable c) => Serializable (a, b, c)) where +instance (Serializable a, Serializable b, Serializable c) => Serializable (a, b, c) where serialize (s, t, u) = "((" ++ serialize s ++ ") (" ++ serialize t ++ ") (" ++ serialize u ++ "))" -instance ((Serializable a, Serializable b, Serializable c, Serializable d) => Serializable (a, b, c, d)) where +instance (Serializable a, Serializable b, Serializable c, Serializable d) => Serializable (a, b, c, d) where serialize (s, t, u, v) = "((" ++ serialize s ++ ") (" ++ serialize t ++ ") (" ++ serialize u ++ ") (" ++ serialize v ++ "))" instance {-# OVERLAPPING #-} Serializable PEnv where diff --git a/stack.yaml b/stack.yaml index 46397eb..b2b0d7f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-18.8 +resolver: lts-20.21 # User packages to be built. # Various formats can be used as shown in the example below. @@ -39,7 +39,8 @@ packages: # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # -# extra-deps: [] +extra-deps: + - 'validation-selective-0.2.0.0' # Override default flag values for local packages and extra-deps # flags: {} From 68efdc207f72b36d9c9ac1a2dfd5e97ac10b78a8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=2E=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 13 Jun 2023 13:58:00 +0200 Subject: [PATCH 226/229] Updated authors and updated copyright years --- exe/Main.hs | 2 +- ldgv.cabal | 5 +++-- package.yaml | 3 ++- 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index 692a9f5..a049c74 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -160,9 +160,9 @@ actionParserInfo :: Opts.ParserInfo (Action ()) actionParserInfo = Opts.info (actionParser <**> Opts.helper) $ mconcat [ Opts.progDesc "An implementation of Label Dependent Session Types (LDST)." , Opts.footer "Authors: \ + \Leon Läufer (networking capability for Channels), \ \Thomas Leyh (CCLDLC implementation), \ \Nils Hagner (interpreter, web frontend), \ - \L. Läufer (networking extension for LDGV), \ \Janek Spaderna (C backend, command line frontend), \ \Peter Thiemann (parser, typechecker)" ] diff --git a/ldgv.cabal b/ldgv.cabal index b1bf886..33346ab 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -9,12 +9,13 @@ version: 0.0.1 synopsis: Frontend, interpreter and C backend for LDGV/LDST homepage: https://github.com/proglang/ldgv#readme bug-reports: https://github.com/proglang/ldgv/issues -author: Thomas Leyh (CCLDLC implementation), +author: Leon Läufer (networking capability for Channels), + Thomas Leyh (CCLDLC implementation), Nils Hagner (web frontend, interpreter), Janek Spaderna (command line fronted, C backend), Peter Thiemann (parser, typechecker) maintainer: thiemann@informatik.uni-freiburg.de -copyright: 2019-2021 Chair of Programming Languages, Uni Freiburg +copyright: 2019-2023 Chair of Programming Languages, Uni Freiburg license: BSD3 license-file: LICENSE build-type: Simple diff --git a/package.yaml b/package.yaml index f7fcbd3..bae1200 100644 --- a/package.yaml +++ b/package.yaml @@ -5,12 +5,13 @@ synopsis: Frontend, interpreter and C backend for LDGV/LDST license: BSD3 license-file: LICENSE author: +- Leon Läufer (networking capability for Channels) - Thomas Leyh (CCLDLC implementation) - Nils Hagner (web frontend, interpreter) - Janek Spaderna (command line fronted, C backend) - Peter Thiemann (parser, typechecker) maintainer: "thiemann@informatik.uni-freiburg.de" -copyright: "2019-2021 Chair of Programming Languages, Uni Freiburg" +copyright: "2019-2023 Chair of Programming Languages, Uni Freiburg" ghc-options: - -Wall From 48e71b2640c43470905714a06b9a6158712e0b9e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=2E=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 13 Jun 2023 14:07:57 +0200 Subject: [PATCH 227/229] Improved author description --- exe/Main.hs | 2 +- ldgv.cabal | 2 +- package.yaml | 10 +++++----- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index a049c74..1af7ad4 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -160,7 +160,7 @@ actionParserInfo :: Opts.ParserInfo (Action ()) actionParserInfo = Opts.info (actionParser <**> Opts.helper) $ mconcat [ Opts.progDesc "An implementation of Label Dependent Session Types (LDST)." , Opts.footer "Authors: \ - \Leon Läufer (networking capability for Channels), \ + \Leon Läufer (LDGVNW: networking capability for Channels), \ \Thomas Leyh (CCLDLC implementation), \ \Nils Hagner (interpreter, web frontend), \ \Janek Spaderna (C backend, command line frontend), \ diff --git a/ldgv.cabal b/ldgv.cabal index 33346ab..5426a54 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -9,7 +9,7 @@ version: 0.0.1 synopsis: Frontend, interpreter and C backend for LDGV/LDST homepage: https://github.com/proglang/ldgv#readme bug-reports: https://github.com/proglang/ldgv/issues -author: Leon Läufer (networking capability for Channels), +author: Leon Läufer (LDGVNW: networking capability for Channels), Thomas Leyh (CCLDLC implementation), Nils Hagner (web frontend, interpreter), Janek Spaderna (command line fronted, C backend), diff --git a/package.yaml b/package.yaml index bae1200..c160608 100644 --- a/package.yaml +++ b/package.yaml @@ -5,11 +5,11 @@ synopsis: Frontend, interpreter and C backend for LDGV/LDST license: BSD3 license-file: LICENSE author: -- Leon Läufer (networking capability for Channels) -- Thomas Leyh (CCLDLC implementation) -- Nils Hagner (web frontend, interpreter) -- Janek Spaderna (command line fronted, C backend) -- Peter Thiemann (parser, typechecker) +- "Leon Läufer (LDGVNW: networking capability for Channels)" +- "Thomas Leyh (CCLDLC implementation)" +- "Nils Hagner (web frontend, interpreter)" +- "Janek Spaderna (command line fronted, C backend)" +- "Peter Thiemann (parser, typechecker)" maintainer: "thiemann@informatik.uni-freiburg.de" copyright: "2019-2023 Chair of Programming Languages, Uni Freiburg" From ed914914c03f867bf6073f85b284f4776f6f8161 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=2E=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 13 Jun 2023 14:09:43 +0200 Subject: [PATCH 228/229] Improved author description #2 --- exe/Main.hs | 2 +- ldgv.cabal | 2 +- package.yaml | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index 1af7ad4..12f3860 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -160,7 +160,7 @@ actionParserInfo :: Opts.ParserInfo (Action ()) actionParserInfo = Opts.info (actionParser <**> Opts.helper) $ mconcat [ Opts.progDesc "An implementation of Label Dependent Session Types (LDST)." , Opts.footer "Authors: \ - \Leon Läufer (LDGVNW: networking capability for Channels), \ + \Leon Läufer (LDGVNW: Networking capability for Channels), \ \Thomas Leyh (CCLDLC implementation), \ \Nils Hagner (interpreter, web frontend), \ \Janek Spaderna (C backend, command line frontend), \ diff --git a/ldgv.cabal b/ldgv.cabal index 5426a54..b9fe3f8 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -9,7 +9,7 @@ version: 0.0.1 synopsis: Frontend, interpreter and C backend for LDGV/LDST homepage: https://github.com/proglang/ldgv#readme bug-reports: https://github.com/proglang/ldgv/issues -author: Leon Läufer (LDGVNW: networking capability for Channels), +author: Leon Läufer (LDGVNW: Networking capability for Channels), Thomas Leyh (CCLDLC implementation), Nils Hagner (web frontend, interpreter), Janek Spaderna (command line fronted, C backend), diff --git a/package.yaml b/package.yaml index c160608..5d52c69 100644 --- a/package.yaml +++ b/package.yaml @@ -5,7 +5,7 @@ synopsis: Frontend, interpreter and C backend for LDGV/LDST license: BSD3 license-file: LICENSE author: -- "Leon Läufer (LDGVNW: networking capability for Channels)" +- "Leon Läufer (LDGVNW: Networking capability for Channels)" - "Thomas Leyh (CCLDLC implementation)" - "Nils Hagner (web frontend, interpreter)" - "Janek Spaderna (command line fronted, C backend)" From 52156fbd236742842f7e7b19e58079911fff81e5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=2E=20L=C3=A4ufer?= <88783053+LLaeufer@users.noreply.github.com> Date: Tue, 13 Jun 2023 14:19:39 +0200 Subject: [PATCH 229/229] Made author description more in line with others --- exe/Main.hs | 2 +- ldgv.cabal | 2 +- package.yaml | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index 12f3860..8e2fe27 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -160,7 +160,7 @@ actionParserInfo :: Opts.ParserInfo (Action ()) actionParserInfo = Opts.info (actionParser <**> Opts.helper) $ mconcat [ Opts.progDesc "An implementation of Label Dependent Session Types (LDST)." , Opts.footer "Authors: \ - \Leon Läufer (LDGVNW: Networking capability for Channels), \ + \Leon Läufer (LDGVNW implementation), \ \Thomas Leyh (CCLDLC implementation), \ \Nils Hagner (interpreter, web frontend), \ \Janek Spaderna (C backend, command line frontend), \ diff --git a/ldgv.cabal b/ldgv.cabal index b9fe3f8..88e3b2b 100644 --- a/ldgv.cabal +++ b/ldgv.cabal @@ -9,7 +9,7 @@ version: 0.0.1 synopsis: Frontend, interpreter and C backend for LDGV/LDST homepage: https://github.com/proglang/ldgv#readme bug-reports: https://github.com/proglang/ldgv/issues -author: Leon Läufer (LDGVNW: Networking capability for Channels), +author: Leon Läufer (LDGVNW implementation), Thomas Leyh (CCLDLC implementation), Nils Hagner (web frontend, interpreter), Janek Spaderna (command line fronted, C backend), diff --git a/package.yaml b/package.yaml index 5d52c69..1a320c2 100644 --- a/package.yaml +++ b/package.yaml @@ -5,7 +5,7 @@ synopsis: Frontend, interpreter and C backend for LDGV/LDST license: BSD3 license-file: LICENSE author: -- "Leon Läufer (LDGVNW: Networking capability for Channels)" +- "Leon Läufer (LDGVNW implementation)" - "Thomas Leyh (CCLDLC implementation)" - "Nils Hagner (web frontend, interpreter)" - "Janek Spaderna (command line fronted, C backend)"